+###--------------------------------------------------------------------------
+### 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;
+}
+
~mdw / odin-cgi / commitdiff