package Odin;
use DBI;
+use Date::Parse;
use Digest::SHA qw(sha256_hex);
use MIME::Base64;
+use POSIX;
###--------------------------------------------------------------------------
### Early utilities.
qr{^https?://}
);
+our $PASTEMAXLEN = 1024*1024;
+
our %COOKIE_DEFAULTS = (
-httponly => undef,
-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 $SHORTURL = "$BASEURL$SHORTURL_PATH";
-our $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
+our $MAIL_DEFDOMAIN = "odin.gg";
+our $MAIL_ADDRMAX_LIVE = 16384;
+our $MAIL_ADDRMAX_RESV = 32;
+our $MAIL_AGEMAX_RESV = 3600;
+
+our ($SCHEME, $DOMAIN, $BASEPATH);
+our ($SHORTURL, $PASTEBIN);
###--------------------------------------------------------------------------
### Miscellaneous utilities.
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 = ();
+ my @val = ();
+ while (@col && $col[1] eq "") { splice @col, 0, 2; }
+ my ($wd, $v) = splice @col, 0, 2;
+ push @fmt, "%s"; push @val, $v;
+ while (@col) {
+ my ($wd, $v) = splice @col, 0, 2;
+ push @fmt, "%-${wd}s";
+ push @val, $v;
+ }
+ printf join(" ", reverse @fmt) . "\n", reverse @val;
+}
+
+sub fmt_time ($) {
+ my ($t) = @_;
+ return $t == -1 ? "--" : strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
+}
+
###--------------------------------------------------------------------------
### Database utilities.
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.
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;
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;
}
return undef unless defined $content;
$content =~ tr/\r//d;
$content =~ s/([^\n])\z/$1\n/;
+ length $content <= $PASTEMAXLEN or
+ fail "invalid paste content", ".badpaste";
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.
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;
~mdw / odin-cgi / blobdiff