From c86aee467ae463cd3fc7ff896f09f2a07d79dad5 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 24 Jul 2015 19:07:10 +0100 Subject: [PATCH] New things for a mail redirection service, with randomized local parts. This is a spiritual successor to my old `cryptomail.distorted.org.uk' service, somewhat simplified, and heavily influenced by Ian Jackson's (independent, I think) `evade.org.uk'/`fyvzl.net' service. --- .gitignore | 3 + Makefile | 13 ++ bin/mailredir.userv | 169 ++++++++++++++++++++++ exim-filter.in | 11 ++ lib/Odin.pm | 397 ++++++++++++++++++++++++++++++++++++++++++++++++++++ sql/setup-mail.sql | 34 +++++ 6 files changed, 627 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100755 bin/mailredir.userv create mode 100644 exim-filter.in create mode 100644 sql/setup-mail.sql diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7108ccc --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +/etc/ +/passwds +/exim-filter diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..0b95944 --- /dev/null +++ b/Makefile @@ -0,0 +1,13 @@ +### -*-makefile-*- + +all:: + +TARGETS += exim-filter +exim-filter: exim-filter.in passwds Makefile + set -e; . ./passwds; umask 077; \ + sed "s;@PASSWORD@;$$exim_db_passwd;g" $< >$@.new; \ + mv $@.new $@ + +CLEAN += $(TARGETS) +all:: $(TARGETS) +clean::; rm -f $(CLEAN) diff --git a/bin/mailredir.userv b/bin/mailredir.userv new file mode 100755 index 0000000..ab8b54d --- /dev/null +++ b/bin/mailredir.userv @@ -0,0 +1,169 @@ +#! /usr/bin/perl + +use lib 'lib'; + +use Odin; + +use DBI; +use Encode; +use Encode::Locale; +use Getopt::Long; +use POSIX; + +###-------------------------------------------------------------------------- +### Main program. + +my $dom = $Odin::MAIL_DEFDOMAIN; +Odin::cmdline_who; + +sub record_opt (\%$$) { + my ($r, $o, $op) = @_; + + if ($o eq "c") { $r->{comment} = $op->arg; } + elsif ($o eq "x") { $r->{expire} = Odin::parse_time $op->arg; } + elsif ($o eq "r") { $r->{recip} = $op->arg; } + else { return undef; } + return 1; +} + +sub gen_opt ($\$\%$$) { + my ($dom, $g, $gp, $o, $op) = @_; + + if ($o eq "g") { + my $a = $op->arg; next OPT unless defined $a; + $$g = Odin::get_generator_class $dom, $a; + } elsif ($o eq "p") { + defined (my $p = $op->arg) or next OPT; + if ($p =~ /^([-\w]+)=(.*)$/) { $gp->{$1} = $2; } + else { $op->err("invalid parameter `$p'"); } + } else { + return undef; + } + return 1; +} + +my $op = Odin::OptParse->new(@ARGV); +OPT: while (my $o = $op->get) { + if ($o eq "d") { + $dom = $op->arg or next OPT; + exists $Odin::MAILDOM_POLICY{$dom} or $op->err("unknown domain `$dom'"); + } else { + $op->unk; + } +} +unless ($op->ok) { + print STDERR "usage: $Odin::PROG [-d DOMAIN] COMMAND [ARGUMENT ...]\n"; + exit 1; +} +@ARGV = $op->rest; + +my $op = shift(@ARGV) // "help"; +if ($op eq "help") { + print <= ?)", $Odin::NOW) { + my ($lpart, $expire, $recip, $comment) = @$r; + Odin::print_columns + Odin::fmt_time $expire => 25, + $lpart => 24, $recip => 32, $comment => 0; + } +} elsif ($op eq "dormant") { + @ARGV and Odin::fail "usage: list"; + for my $r (Odin::redir_query Odin::open_db, $dom, $Odin::WHO, + "(st = 'dormant' OR + (st = 'live' AND expire <> -1 AND expire < ?))", + $Odin::NOW) { + my ($lpart, $expire, $recip, $comment) = @$r; + Odin::print_columns $lpart => 24, $recip => 32, $comment => 0; + } +} elsif ($op eq "reserved") { + @ARGV and Odin::fail "usage: reserved"; + for my $r (Odin::redir_query Odin::open_db, $dom, $Odin::WHO, + "st = 'reserved' AND expire >= ?", $Odin::NOW) { + my ($lpart, $expire, $recip, $comment) = @$r; + Odin::print_columns Odin::fmt_time $expire => 25, $lpart => 0; + } +} elsif ($op eq "new") { + my $op = Odin::OptParse->new(@ARGV); + my $gencls = Odin::default_generator_class $dom; + my %gp = (); + my %r = (); + while (my $o = $op->get) { + gen_opt $dom, $gencls, %gp, $o, $op + or record_opt %r, $o, $op + or $op->unk; + } + my @a = $op->rest; + if (@a) { $r{recip} = shift @a; } + !@a or $op->bad; + $op->ok or Odin::fail "usage: new [-GENOPTS] [-RECOPTS] RECIP"; + my $gen = $gencls->new($dom, \%gp); + my $l = Odin::new_redir $dom, $gen, %r; + print $l, "\n"; +} elsif ($op eq "reserve") { + my $op = Odin::OptParse->new(@ARGV); + my $gencls = Odin::default_generator_class $dom; + my %gp = (); + while (my $o = $op->get) { + gen_opt $dom, $gencls, %gp, $o, $op + or $op->unk; + } + my @a = $op->rest; + my $n = 1; + if (@a) { + $n = shift @a; + $n =~ /^\d+$/ or $op->err("invalid count `$n'"); + } + @a and $op->bad; + $op->ok or Odin::fail "usage: reserve [-GENOPTS] N"; + my $gen = $gencls->new($dom, \%gp); + for my $l (Odin::reserve_redir $dom, $gen, $n) { print $l, "\n"; } +} elsif ($op eq "release") { + my $op = Odin::OptParse->new(@ARGV); + my $all = 0; + while (my $o = $op->get) { + if ($o eq "a") { $all = 1; } + else { $op->unk; } + } + my @a = $op->rest; + !!$all == !@a or $op->bad; + $op->ok or Odin::fail "usage: release {-a | LPART ...}"; + if ($all) { Odin::release_all_redir $dom; } + else { Odin::release_redir $dom, @a; } +} elsif ($op eq "disable") { + @ARGV or Odin::fail "usage: disable LPART ..."; + Odin::disable_redir $dom, @ARGV; +} elsif ($op eq "set") { + my $op = Odin::OptParse->new(@ARGV); + my %r = (); + while (my $o = $op->get) { + record_opt %r, $o, $op + or $op->unk; + } + my @a = $op->rest; + my $l = shift @a or $op->bad; + @a and $op->bad; + $op->ok or Odin::fail "usage: set [-RECOPTS] LPART"; + Odin::modify_redir $dom, $l, %r; +} else { + Odin::fail "unknown operation `$op'"; +} diff --git a/exim-filter.in b/exim-filter.in new file mode 100644 index 0000000..0a6b477 --- /dev/null +++ b/exim-filter.in @@ -0,0 +1,11 @@ +# Exim filter -*-conf-*- + +if "${lookup pgsql { \ + servers=db/odin/exim/@PASSWORD@; \ + SELECT recip FROM odin_maildeliver \ + WHERE lpart = '${quote_pgsql:$local_part}' AND \ + dom = '$domain' } {!$value}{}}" matches "^(.+)\\$" +then + deliver ${s_1:$1} + finish +endif diff --git a/lib/Odin.pm b/lib/Odin.pm index a704165..7182af2 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,7 +42,22 @@ our %COOKIE_DEFAULTS = ( -max_age => 3600 ); +our $ALPHA = "abcdefghijklmnopqrstuvwxyz"; +our $NUM = "0123456789"; +our $SAFECH = qr/^[-\w_.+]*$/; +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 ($SCHEME, $DOMAIN, $BASEPATH); our ($SHORTURL, $PASTEBIN); @@ -84,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 = (); @@ -462,6 +493,199 @@ sub tidy_pastebin_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", 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 = $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) = @_; + my $db = open_db; + my $l; + + check_fixup_redir $r; + Odin::xact { + clear_redir_reservations $db; + $l = Odin::gen_redir_name $db, $gen; + insert_record $db, "odin_mailredir", + lpart => $l, dom => $dom, owner => $WHO, st => 'live', + recip => $r->{recip} // qualify_recip $Odin::WHO, + expire => $r->{expire} // -1, + comment => $r->{comment} // ""; + 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, $l, $r) = @_; + my $db = open_db; + + check_fixup_redir $r; + Odin::xact { + clear_redir_reservations $db; + 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. package Odin::OptParse; @@ -506,6 +730,177 @@ 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; @@ -516,6 +911,8 @@ require "config.pl"; 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"; diff --git a/sql/setup-mail.sql b/sql/setup-mail.sql new file mode 100644 index 0000000..e1b535c --- /dev/null +++ b/sql/setup-mail.sql @@ -0,0 +1,34 @@ +/* -*-sql-*- + * + * Plain old SQL for setting up the tables for Odin mail redirection. + */ + +/* The various tools assume that the database is appropriate configured with + * the SERIALIZABLE isolation level. + */ + +begin; + +drop view if exists odin_maildeliver; +drop table if exists odin_mailredir; + +create table odin_mailredir + (lpart varchar(64) not null, + dom varchar(128) not null, + owner varchar(64) not null, + recip text not null default '', + expire bigint not null, + st varchar(16) not null default 'live', + comment text not null default '', + primary key (lpart, dom)); +create index odin_mailredir_by_owner_st on odin_mailredir (owner, st); +create index odin_mailredir_by_expire_st on odin_mailredir (expire, st); +create index odin_mailredir_by_recip on odin_mailredir (recip); + +create view odin_maildeliver as + select lpart, dom, recip from odin_mailredir + where st = 'live' and + (expire = -1 or + expire > extract(epoch from current_timestamp)); + +commit; -- 2.11.0