#!/usr/bin/perl -w

# Cyrus Quota Postfix Policy Daemon
# Version: 0.03
# Author: Omni Flux
# Most recent version is available at http://www.omniflux.com/devel/
#
# Edited by Benjamin Donnachie <benjamin@py-soft.co.uk> to add
#  initial support for aliases.
#
# Policy Daemon code based on postfix-policyd-spf by Meng Weng Wong
#  available at http://www.openspf.org/
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 dated June, 1991.

use strict;
use IO::Socket::UNIX;
use Sys::Syslog qw(:DEFAULT setlogsock);
use Text::Netstring qw(netstring_encode netstring_decode netstring_read netstring_verify);

# ----------------------------------------------------------
#                      configuration
# ----------------------------------------------------------

#
# Site specific details
#
my $mydomain = 'example.tld';
my $aliasfile = '/etc/postfix/quota_aliases';

#
# Responses to postfix
#
my $default_response   = 'DUNNO';
my $overquota_response = '552 5.2.2 Over quota';

#
# Settings for conecting to the Cyrus smmap daemon
# This is the default for Debian systems
#
my $socket = "/var/run/cyrus/socket/smmap";

#
# Syslogging options for verbose mode and for fatal errors.
# NOTE: comment out the $syslog_socktype line if syslogging does not
# work on your system.
#
my $syslog_socktype = 'unix';
my $syslog_facility = 'mail';
my $syslog_options  = 'pid';
my $syslog_priority = 'info';
my $syslog_ident    = 'postfix/policy-cyrquota';

# ----------------------------------------------------------
#                   minimal documentation
# ----------------------------------------------------------

#
# Usage: cyrquota-pf_policy.pl [-v]
#
# This policy server checks if a Cyrus mail account is over quota.
#
# This method does create a race condition as it is possible
# for a message to pass this check while a message which will
# push the account over quota is being delivered to cyrus, but
# this should be correct in the majority of cases, and should
# never incorrectly reject mail.
#
# This method will not catch overquota accounts if postfix
# rewrites the address before performing local delivery
# (aliases, virtual domains).
#
# This documentation assumes you have read Postfix's
# README_FILES/SMTPD_POLICY_README
#
# Logging is sent to syslogd.
#
# To run this from /etc/postfix/master.cf:
#
#    cyrquota-policy	unix	-	n	n	-	-	spawn
#       user=nobody argv=/usr/bin/perl /usr/local/sbin/cyrquota-pf_policy.pl
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_recipient_restrictions =
#    ...
#    reject_unlisted_recipient,
#    check_policy_service unix:private/cyrquota-policy,
#    permit_sasl_authenticated,
#    reject_unauth_destination
#    ...
#
# This policy should be included after reject_unlisted_recipient if used,
# but before any permit rules or maps which return OK.
#
# To test this script by hand, execute:
#
#   % perl cyrquota-pf_policy.pl
#
# Each query is a bunch of attributes. Order does not matter.
#
#    request=smtpd_access_policy
#    recipient=bar@foo.tld
#    [empty line]
#
# The policy server script will answer in the same style, with an
# attribute list followed by a empty line:
#
#    action=dunno
#    [empty line]

# ----------------------------------------------------------
#                      initialization
# ----------------------------------------------------------

#
# This process runs as a daemon, so it can't log to a terminal. Use
# syslog so that people can actually see our messages.
#
setlogsock ($syslog_socktype);
openlog ($syslog_ident, $syslog_options, $syslog_facility);

#
# Parse commandline.
#
my $verbose = 0;
while (my $option = shift (@ARGV)) {
	if ($option eq '-v') {
		$verbose = 1;
	} else {
		fatal_exit ("Invalid option: $option. Usage: $0 [-v]");
	}
}

#
# Unbuffer standard output.
#
select ((select (STDOUT), $| = 1)[0]);

# ----------------------------------------------------------
#                           main
# ----------------------------------------------------------

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#

my $sock = IO::Socket::UNIX->new(Peer => $socket) or fatal_exit ("unable to connect to smmap daemon");

my %attr;
while (<STDIN>) {
	chomp;
	if (/=/) {
		my ($k, $v) = split (/=/, $_, 2);
		$attr{$k} = $v;
		syslog (debug => "Attribute: %s=%s", $k, $v) if $verbose;
		next
	} elsif (length) {
		syslog (warning => sprintf ("warning: ignoring garbage: %.100s", $_));
		next;
	}

	if ($attr{'request'} ne 'smtpd_access_policy') {
		fatal_exit ("unrecognized request type: '$attr{'request'}'")
	}

	my $action = $default_response;
	my $recipient = checkaliases ($attr{'recipient'});

	if (lc (rhs ($recipient)) eq lc ($mydomain))
	{
		print $sock netstring_encode ("0 " . lhs ($recipient));
		my $result = netstring_read ($sock);
		if (!$result) {
			syslog (warning => "query error");
		}
		elsif ($result eq "") {
			syslog (warning => "lost connection to smmsp daemon");
		}
		else {
			if (netstring_verify ($result)) {
				$result = netstring_decode ($result);
				if ($result =~ /^(PERM|TEMP) Over quota$/) {
					$action = $overquota_response;
				}
			}
			else {
				syslog (warning => "error decoding smmsp response");
			}
		}
	}
	else
	{
		syslog (debug => "Skipping external domain: %s", rhs ($recipient)) if $verbose;
	}

	print STDOUT "action=$action\n\n";
	%attr = ();
}

# ----------------------------------------------------------
#                       subroutines
# ----------------------------------------------------------

#
# Log an error and abort.
#
sub fatal_exit {
	syslog (err => "fatal_exit: @_");
	die ("fatal: @_");
}

sub lhs {
	my $string = shift;
	for ($string) {
		s/\@.*$//;
	}
	return $string;
}

sub rhs {
	my $string = shift;
	for ($string) {
		s/.*\@//;
	}
	return $string;
}

sub checkaliases {
	my $address = shift;
	my $key = "";
	my $value = "";

	open (FILE, "<$aliasfile");
	while (<FILE>) {
		chomp;
		my ($key, $value) = split (/\s+/);

		if ($key eq $address) {
			close (FILE);
			syslog (debug => "Found alias: %s -> %s", $key, $value) if $verbose;
			return $value;
		}
		elsif (($key =~ /^\@.*/) && $key eq ($address =~ /.*(\@.*)/)) {
			if ($value =~ /^\@.*/) {
				close (FILE);
				syslog (debug => "Found alias: %s -> %s", $key, $value) if $verbose;
				return lhs ($address) . $value;
			}
			else {
				syslog (debug => "Found alias: %s -> %s", $key, $value) if $verbose;
				close (FILE);
				return $value;
			}
		}

	}

	close (FILE);
	return $address;
}