=head1 NAME

forwarding - plugin to implement DB-based E-mail forwarding

=head1 SYNOPSIS

	# in config/plugins
	forwarding [OPTION value]...

=cut

use DBI;
use Net::SMTP;
use Mail::Address;
use Cache::Memcached::Fast;
use Qpsmtpd::Constants;

our %defaults = (
	DATABASE => 'my_db_name',
	DB_USER => 'username',
	DB_PASS => 'password',
	MAIL_SERVER => 'out.smtp.example.com',
	MAIL_PORT => 2525,
	MEMCACHED_SERVER => 'localhost:2526',
	MEMCACHED_NAMESPACE => 'aliases'
);

sub register {
	my ($self, $qp, @args) = @_;

	%{$self->{_args}} = ( %defaults, @args );

	$self->{_memcache} = new Cache::Memcached::Fast {
		servers => [ $self->{_args}{MEMCACHED_SERVER} ],
		namespace => $self->{_args}{MEMCACHED_NAMESPACE}
	};

	repopulate_cache( $self );
	$self->{_cache_version} = $self->{_memcache}->get( '_version' );

}

sub hook_pre_connection {
	my $self = shift;

	my $version = $self->{_memcache}->get( '_version' );
	if ( $self->{_cache_version} != $version ) {
		repopulate_cache( $self ) or return (DENYSOFT, "Couldn't populate alias cache");
		$self->{_cache_version} = $version;
	}

	return DECLINED;
}

sub repopulate_cache {
	my $self = shift;

	$self->log( LOGNOTICE, "Updating the alias cache" );

	$self->{_address_cache} = {
		bounce => undef,
		webmaster => 'Webmaster@example.com',
		admin => 'mail-admin@example.com'
	};

	my $dbh = DBI->connect( 'dbi:Pg:dbname=' . $self->{_args}{DATABASE}, DB_USER, DB_PASS )
		or warn "Can't connect to DB" and return;

	( my $sth = $dbh->prepare( << '' ) )->execute;
		SELECT e_mail_alias, '_GROUP' FROM groups WHERE e_mail_alias IS NOT NULL
			UNION
		SELECT forward_username, forward_to FROM users WHERE forward_username IS NOT NULL

	$sth->bind_columns( \my($alias, $address) );
	while ( $sth->fetch ) {
		for ( split /,\s*/, $alias ) {
			$self->log( LOGDEBUG, "Caching $_ -> $address" );
			$self->{_address_cache}->{ lc $_ } = $address;
		}
	}

	$dbh->disconnect;

	return length keys %{$self->{_address_cache}};
}

sub hook_mail {
	my ($self, $transaction, $sender) = @_;

	return (DENY, "There's no such user here") if $sender->host
		and $sender->host eq 'example.com'
		and ! exists $self->{_address_cache}->{ lc $sender->user };

	my $c = $self->qp->connection;
	my $message = { sender => $sender };
	my $messages = $c->notes( 'mg_messages' );
	push @$messages, $message;
	$c->notes( mg_messages => $messages );
	$c->notes( mg_current_message => $message );

	return DECLINED;
}

sub hook_rcpt {
	my ($self, $transaction, $rcpt) = @_;

	my $to_user = lc $rcpt->user;

	$to_user =~ s/\+.*//; # Handle plus addressing

	return DECLINED if $to_user =~ m/^ical_/;

	$self->log( LOGDEBUG, "Looking up $to_user" );

	# Get group or forwarding record, or deny message if there isn't one

	my $destination = $self->{_address_cache}->{ lc $to_user };
	my $message = $self->qp->connection->notes('mg_current_message');

	if ( ! $destination ) {

		$self->log( LOGNOTICE, sprintf 'Delivery denied (address %s not found)', $rcpt->address );
		return ( DENY, sprintf 'Address %s not found', $rcpt->address );

	} elsif ( $destination eq '_GROUP' ) {

		my $groups = $message->{groups} ||= [];
		push @$groups, $rcpt;
		return OK;

	} elsif ( defined $destination ) {

		my $users = $message->{users} ||= [];
		push @$users, split /,\s*/, $destination;
		return OK;

	} else {

		return DECLINED;

	}
}

sub hook_data_post {
  my ($self, $transaction) = @_;

	my $headers = $transaction->header;

	return DECLINED if $headers->get('To') =~ m/ical_.*\+/;

	my $x_loop = $headers->get('X-Loop') || '';
	if ( $x_loop eq "bounce\@example.com" ) {
		return ( DENY, 'Got message with my X-Loop header' );
	}

	my $subject = $headers->get('Subject');
	if ( $subject =~ m{out of office|autoreply}i ) {
		return ( DENY, 'Dumping vacation autoreply' );
	}

	my $from = (Mail::Address->parse( $headers->get('From') ))[0]->address;

	my $message = $self->qp->connection->notes('mg_current_message');

	my $dbh;

	for my $rcpt ( @{ $message->{groups} } ) {

		my $to_user = lc $rcpt->user;

		$dbh ||= DBI->connect( 'dbi:Pg:dbname=' . $self->{_args}{DATABASE}, DB_USER, DB_PASS )
		 	or return (DENYSOFT_DISCONNECT, "Couldn't connect to database");

		my $group = $dbh->selectrow_hashref( << '', {}, $to_user );
			SELECT group_id, name, e_mail_alias, e_mail_to_alias_allowed_from, custom_e_mail_query, log_all_recipients
			FROM groups WHERE lower(e_mail_alias) = ?

		my $group_error = sub {
			delete $message->{groups};
			return (
				DENY,
				sprintf 'The group "%s" <%s> only accepts mail from %s; message from %s rejected',
					$group->{name}, $rcpt->address, $_[0], $from
			);
		};

		if (
			! $group->{e_mail_to_alias_allowed_from}
			or $group->{e_mail_to_alias_allowed_from} eq 'nobody'
		) {
			return $group_error->(
				sprintf 'The group "%s" <%s> does not accept mail', $group->{name}, $rcpt->address
			);
		}

		if ( $group->{e_mail_to_alias_allowed_from} ne 'anybody' ) {
			# is there a user record with the sender's e-mail address?

			my $user ||= $dbh->selectrow_hashref( << '', {}, lc $from, lc $from )
				SELECT user_id FROM users WHERE lower(e_mail) = ? OR lower(alternate_from_e_mail) = ?

				or return $group_error->( 'registered users of the Web site'	);

			if ( $group->{e_mail_to_alias_allowed_from} eq 'admins' ) {
				# has the user been accepted as a member of the 'Web-site admins' group?

				$dbh->selectrow_array( << '', {}, $user->{user_id} )
					SELECT 1 FROM user_in_group JOIN groups USING (group_id)
					WHERE user_id = ? AND groups.name = 'Web-site admins' AND is_accepted IS TRUE

					or return $group_error->(	'Web-site admins' );

			} elsif ( $group->{e_mail_to_alias_allowed_from} eq 'group' ) {
				# has the user been accepted as a member of this group?

				$dbh->selectrow_array( << '', {}, $user->{user_id}, $group->{group_id} )
					SELECT 1 FROM user_in_group
					WHERE user_id = ? AND group_id = ? AND is_accepted IS TRUE

					or return $group_error->( 'its members'	);

			} elsif ( $group->{e_mail_to_alias_allowed_from} eq 'group_admins' ) {
				# is the user an administrator of this group?

				$dbh->selectrow_array( << '', {}, $user->{user_id}, $group->{group_id} )
					SELECT 1 FROM user_in_group
					WHERE user_id = ? AND group_id = ? AND is_accepted IS TRUE AND is_admin IS TRUE

					or return $group_error->( 'its administrators'	);

			} elsif ( $group->{e_mail_to_alias_allowed_from} eq 'members' ) {
				# has the user been accepted as a member of a member group?

				$dbh->selectrow_array( << '', {}, $user->{user_id} )
					SELECT 1 FROM user_in_group JOIN groups USING (group_id)
					WHERE user_id = ? AND is_accepted IS TRUE AND membership_type_id IS NOT NULL
					AND groups.is_suspended IS NOT TRUE

					or return $group_error->( 'users associated with member firms' );

			}

		}

		$group->{rcpt} = $rcpt; # Keep a link to the rcpt object in the group hash

		$rcpt = $group; # Replace the rcpt objects in the connection note with group hashes

	}

	$self->qp->connection->notes( mg_dbh => $dbh ) if $dbh;

	if ( $message->{groups} || $message->{users} ) {

		my %desired_tags = map { $_ => 1 } qw(
			From To CC Bcc Subject Date Content-Type Content-Transfer-Encoding
			MIME-Version List-Id X-Loop
		);
		$headers->delete( $_ ) for grep ! $desired_tags{$_}, $headers->tags;

		$message->{body} = $transaction->body_as_string;
		$message->{from} = $from;
		$message->{headers} = $headers;

	}

	return DECLINED;
}

sub hook_queue {
  my ($self, $transaction) = @_;

	my $message = $self->qp->connection->notes('mg_current_message');

	if ( $message->{groups} || $message->{users} ) {
		return OK;
	} else {
		return DECLINED;
	}
}

sub hook_post_connection {
  my ($self) = @_;

	my $dbh;

	my $messages = $self->qp->connection->notes('mg_messages') or return DECLINED;

	for my $message ( @$messages ) {

		next unless ( $message->{groups} || $message->{users} ) && $message->{body};

		my $headers = $message->{headers};
		$headers->replace( 'X-Original-Sender', $message->{sender} );
		my $subject = $headers->get('Subject');

		my $smtp = Net::SMTP->new(
			Host => $self->{_args}{MAIL_SERVER}, Port => $self->{_args}{MAIL_PORT}, Timeout => 10, Debug => 0
		) or $self->log( LOGCRIT, "Timeout connecting to SMTP server - message not mailed" );

		for my $address ( @{ $message->{users} } ) {

			$self->log(LOGDEBUG, $headers->as_string);

			$self->log( LOGNOTICE,
				sprintf 'Forwarding mail from %s to %s', $message->{from}, $address
			);

			$smtp->mail( "bounce\@example.com" );
			$smtp->to( $address );
			$smtp->data;
			$smtp->datasend( $headers->as_string );
			$smtp->datasend( $message->{body} );
			$smtp->dataend;

		}

		for my $group ( @{ $message->{groups} } ) {

			$headers->replace( 'List-Id', $group->{rcpt}->address );
			$headers->replace( 'X-Loop', "bounce\@example.com" );

			$subject =~ s/\[[^\]]+\] //;
			$subject = sprintf '[%s] %s', $group->{rcpt}->address, $subject;
			$headers->replace( 'Subject', $subject );

			$self->log( LOGDEBUG, $headers->as_string );

			$self->log( LOGNOTICE,
				sprintf 'Forwarding mail from %s to group alias "%s"',
					$message->{from}, $group->{e_mail_alias}
			);

	 		$dbh ||= $self->qp->connection->notes('mg_dbh')
				|| DBI->connect( 'dbi:Pg:dbname=' . $self->{_args}{DATABASE}, DB_USER, DB_PASS )
			 	or $self->log( LOGCRIT, "Couldn't connect to database" ) && next;

			$dbh->begin_work;

			if ( $group->{custom_e_mail_query} ) {

				$dbh->prepare( 'DECLARE csr1 CURSOR FOR ' . $group->{custom_e_mail_query} )->execute;

			} else {

				$dbh->prepare( << '' )->execute( $group->{group_id} );
					DECLARE csr1 CURSOR FOR
					SELECT user_id, first_name, last_name, e_mail
					FROM user_in_group JOIN users USING (user_id)
					WHERE group_id = ? AND is_accepted IS TRUE
						AND is_suspended IS NOT TRUE AND bounced_mail IS NOT TRUE

			}

			BLOCK: while ( ( my $sth = $dbh->prepare( 'FETCH 500 FROM csr1' ) )->execute > 0 ) {

				$smtp->mail( "bounce\@example.com" );

				ROW: while ( my ($user_id, $first_name, $last_name, $e_mail) = $sth->fetchrow ) {
					next unless $e_mail;
					my ($user, $domain) = split '@', $e_mail, 2;
					if (
						$domain eq 'example.com' and
						my $alias = $self->{_address_cache}->{ lc((split '\+', $user)[0]) }
					) {
						$self->log( LOGDEBUG, "$e_mail => $alias" );
						$e_mail = $alias unless $alias eq '_GROUP';
					}
					$self->log( LOGDEBUG, "Forwarding to $e_mail" ) if $group->{log_all_recipients};
					$smtp->to( $e_mail );
				}

				$smtp->data;
				$smtp->datasend( $headers->as_string );
				$smtp->datasend( $message->{body} );
				$smtp->dataend;

			}

			$dbh->commit;

		}

	}

	return OK;
}