1#!/usr/bin/perl
2
3use DB_File;
4use Fcntl;
5use Sys::Syslog qw(:DEFAULT setlogsock);
6
7#
8# Usage: greylist.pl [-v]
9#
10# Demo delegated Postfix SMTPD policy server. This server implements
11# greylisting. State is kept in a Berkeley DB database.  Logging is
12# sent to syslogd.
13#
14# How it works: each time a Postfix SMTP server process is started
15# it connects to the policy service socket, and Postfix runs one
16# instance of this PERL script.  By default, a Postfix SMTP server
17# process terminates after 100 seconds of idle time, or after serving
18# 100 clients. Thus, the cost of starting this PERL script is smoothed
19# out over time.
20#
21# To run this from /etc/postfix/master.cf:
22#
23#    policy  unix  -       n       n       -       -       spawn
24#      user=nobody argv=/usr/bin/perl /usr/libexec/postfix/greylist.pl
25#
26# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
27#
28#    smtpd_recipient_restrictions =
29#	...
30#	reject_unauth_destination
31#	check_policy_service unix:private/policy
32#	...
33#
34# NOTE: specify check_policy_service AFTER reject_unauth_destination
35# or else your system can become an open relay.
36#
37# To test this script by hand, execute:
38#
39#    % perl greylist.pl
40#
41# Each query is a bunch of attributes. Order does not matter, and
42# the demo script uses only a few of all the attributes shown below:
43#
44#    request=smtpd_access_policy
45#    protocol_state=RCPT
46#    protocol_name=SMTP
47#    helo_name=some.domain.tld
48#    queue_id=8045F2AB23
49#    sender=foo@bar.tld
50#    recipient=bar@foo.tld
51#    client_address=1.2.3.4
52#    client_name=another.domain.tld
53#    instance=123.456.7
54#    sasl_method=plain
55#    sasl_username=you
56#    sasl_sender=
57#    size=12345
58#    [empty line]
59#
60# The policy server script will answer in the same style, with an
61# attribute list followed by a empty line:
62#
63#    action=dunno
64#    [empty line]
65#
66
67#
68# greylist status database and greylist time interval. DO NOT create the
69# greylist status database in a world-writable directory such as /tmp
70# or /var/tmp. DO NOT create the greylist database in a file system
71# that can run out of space.
72#
73# In case of database corruption, this script saves the database as
74# $database_name.time(), so that the mail system does not get stuck.
75#
76$database_name="/var/mta/greylist.db";
77$greylist_delay=60;
78
79#
80# Auto-whitelist threshold. Specify 0 to disable, or the number of
81# successful "come backs" after which a client is no longer subject
82# to greylisting.
83#
84$auto_whitelist_threshold = 10;
85
86#
87# Syslogging options for verbose mode and for fatal errors.
88# NOTE: comment out the $syslog_socktype line if syslogging does not
89# work on your system.
90#
91$syslog_socktype = 'unix'; # inet, unix, stream, console
92$syslog_facility="mail";
93$syslog_options="pid";
94$syslog_priority="info";
95
96#
97# Demo SMTPD access policy routine. The result is an action just like
98# it would be specified on the right-hand side of a Postfix access
99# table.  Request attributes are available via the %attr hash.
100#
101sub smtpd_access_policy {
102    my($key, $time_stamp, $now, $count);
103
104    # Open the database on the fly.
105    open_database() unless $database_obj;
106
107    # Search the auto-whitelist.
108    if ($auto_whitelist_threshold > 0) {
109        $count = read_database($attr{"client_address"});
110        if ($count > $auto_whitelist_threshold) {
111	    return "dunno";
112        }
113    }
114
115    # Lookup the time stamp for this client/sender/recipient.
116    $key =
117	lc $attr{"client_address"}."/".$attr{"sender"}."/".$attr{"recipient"};
118    $time_stamp = read_database($key);
119    $now = time();
120
121    # If this is a new request add this client/sender/recipient to the database.
122    if ($time_stamp == 0) {
123	$time_stamp = $now;
124	update_database($key, $time_stamp);
125    }
126
127    # The result can be any action that is allowed in a Postfix access(5) map.
128    #
129    # To label mail, return ``PREPEND'' headername: headertext
130    #
131    # In case of success, return ``DUNNO'' instead of ``OK'' so that the
132    # check_policy_service restriction can be followed by other restrictions.
133    #
134    # In case of failure, specify ``DEFER_IF_PERMIT optional text...''
135    # so that mail can still be blocked by other access restrictions.
136    #
137    syslog $syslog_priority, "request age %d", $now - $time_stamp if $verbose;
138    if ($now - $time_stamp > $greylist_delay) {
139	# Update the auto-whitelist.
140	if ($auto_whitelist_threshold > 0) {
141	    update_database($attr{"client_address"}, $count + 1);
142	}
143	return "dunno";
144    } else {
145	return "defer_if_permit Service is unavailable";
146    }
147}
148
149#
150# You should not have to make changes below this point.
151#
152sub LOCK_SH { 1 };	# Shared lock (used for reading).
153sub LOCK_EX { 2 };	# Exclusive lock (used for writing).
154sub LOCK_NB { 4 };	# Don't block (for testing).
155sub LOCK_UN { 8 };	# Release lock.
156
157#
158# Log an error and abort.
159#
160sub fatal_exit {
161    my($first) = shift(@_);
162    syslog "err", "fatal: $first", @_;
163    exit 1;
164}
165
166#
167# Open hash database.
168#
169sub open_database {
170    my($database_fd);
171
172    # Use tied database to make complex manipulations easier to express.
173    $database_obj = tie(%db_hash, 'DB_File', $database_name,
174			    O_CREAT|O_RDWR, 0644, $DB_BTREE) ||
175	fatal_exit "Cannot open database %s: $!", $database_name;
176    $database_fd = $database_obj->fd;
177    open DATABASE_HANDLE, "+<&=$database_fd" ||
178	fatal_exit "Cannot fdopen database %s: $!", $database_name;
179    syslog $syslog_priority, "open %s", $database_name if $verbose;
180}
181
182#
183# Read database. Use a shared lock to avoid reading the database
184# while it is being changed. XXX There should be a way to synchronize
185# our cache from the on-file database before looking up the key.
186#
187sub read_database {
188    my($key) = @_;
189    my($value);
190
191    flock DATABASE_HANDLE, LOCK_SH ||
192	fatal_exit "Can't get shared lock on %s: $!", $database_name;
193    # XXX Synchronize our cache from the on-disk copy before lookup.
194    $value = $db_hash{$key};
195    syslog $syslog_priority, "lookup %s: %s", $key, $value if $verbose;
196    flock DATABASE_HANDLE, LOCK_UN ||
197	fatal_exit "Can't unlock %s: $!", $database_name;
198    return $value;
199}
200
201#
202# Update database. Use an exclusive lock to avoid collisions with
203# other updaters, and to avoid surprises in database readers. XXX
204# There should be a way to synchronize our cache from the on-file
205# database before updating the database.
206#
207sub update_database {
208    my($key, $value) = @_;
209
210    syslog $syslog_priority, "store %s: %s", $key, $value if $verbose;
211    flock DATABASE_HANDLE, LOCK_EX ||
212	fatal_exit "Can't exclusively lock %s: $!", $database_name;
213    # XXX Synchronize our cache from the on-disk copy before update.
214    $db_hash{$key} = $value;
215    $database_obj->sync() &&
216	fatal_exit "Can't update %s: $!", $database_name;
217    flock DATABASE_HANDLE, LOCK_UN ||
218	fatal_exit "Can't unlock %s: $!", $database_name;
219}
220
221#
222# Signal 11 means that we have some kind of database corruption (yes
223# Berkeley DB should handle this better).  Move the corrupted database
224# out of the way, and start with a new database.
225#
226sub sigsegv_handler {
227    my $backup = $database_name . "." . time();
228
229    rename $database_name, $backup ||
230	fatal_exit "Can't save %s as %s: $!", $database_name, $backup;
231    fatal_exit "Caught signal 11; the corrupted database is saved as $backup";
232}
233
234$SIG{'SEGV'} = 'sigsegv_handler';
235
236#
237# This process runs as a daemon, so it can't log to a terminal. Use
238# syslog so that people can actually see our messages.
239#
240setlogsock $syslog_socktype;
241openlog $0, $syslog_options, $syslog_facility;
242
243#
244# We don't need getopt() for now.
245#
246while ($option = shift(@ARGV)) {
247    if ($option eq "-v") {
248	$verbose = 1;
249    } else {
250	syslog $syslog_priority, "Invalid option: %s. Usage: %s [-v]",
251		$option, $0;
252	exit 1;
253    }
254}
255
256#
257# Unbuffer standard output.
258#
259select((select(STDOUT), $| = 1)[0]);
260
261#
262# Receive a bunch of attributes, evaluate the policy, send the result.
263#
264while (<STDIN>) {
265    if (/([^=]+)=(.*)\n/) {
266	$attr{substr($1, 0, 512)} = substr($2, 0, 512);
267    } elsif ($_ eq "\n") {
268	if ($verbose) {
269	    for (keys %attr) {
270		syslog $syslog_priority, "Attribute: %s=%s", $_, $attr{$_};
271	    }
272	}
273	fatal_exit "unrecognized request type: '%s'", $attr{request}
274	    unless $attr{"request"} eq "smtpd_access_policy";
275	$action = smtpd_access_policy();
276	syslog $syslog_priority, "Action: %s", $action if $verbose;
277	print STDOUT "action=$action\n\n";
278	%attr = ();
279    } else {
280	chop;
281	syslog $syslog_priority, "warning: ignoring garbage: %.100s", $_;
282    }
283}
284