#!/usr/bin/perl -Tws
# ==========================================================================
# Copyright (C) 2005, Guy Antony Halse, All Rights Reserved.
# Please send bug reports and comments to guy@rucus.ru.ac.za
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met: 
#
# Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
#
# Neither name Guy Antony Halse nor the names of any contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
# IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# ==========================================================================

use strict;
use vars qw($debug);
use Net::SMTP;
use File::Basename;

# Untaint the path.  We don't trust users ...
BEGIN { $ENV{'PATH'} = ''; };

#
# Plain Old Documentation (POD) at the end of the file.  Look for =head1.
#
# QMQP Notes ...
# - see http://cr.yp.to/proto/qmqp.html
# - client sends concatenated netstrings encoded as a netstring
#   - first one is the message
#   - second is the envelope sender
#   - remainder are recipients
# - server response is one of K, Z or D followed by an 8-bit safe descriptive
#   string, all encoded as a netstring.
#   - K means we've accepted the message with *all recepients*
#   - Z means temporary deferal, so use only when message format is valid
#   - D means we decline the message, i.e. hard fail
# - we must terminate after an hour
#

#
# Subroutine send info back to the client in netstring format.
# Note that this is *not* 8-bit clean (http://cr.yp.to/proto/8bittext.html)
# so make sure that anything you pass to it is 8-bit clean.  This could also
# be done with netstring_encode from Text::Netstring
#
sub netout($;$) {
  my ($out, $ret) = @_;
  print STDERR "$out\n" if defined($debug);
  print length($out) . ':' . $out . ',';
  exit defined ($ret) ? $ret : 0;
}

#
# Subroutine to split a netstring off a string and returns the remainder.
# This *can't* be done with Text::Netstring which is why we brew our own.
#
sub getnetstr ($) {
  my $in = shift;
  my ($len) = $in =~ m/^(\d+):/;
  my ($message) = substr($in, length($len) + 1, $len);
  ($message) = $message =~ m/^(.+)$/s; # taint check - we don't really care so long as it is 8-bit clean

  netout ('DInvalid terminator in component netstring', 1) unless substr($in, length($len) + 1 + $len, 1) eq ',';
  return (substr($in, length($len) + 2 + $len), $message);
}

#
# QMQP requires we terminate the conversation after an hour, so we set up an
# alarm to enforce this.  We'll defer the message on the assumption that
# this isn't normal.
#
$SIG{'ALRM'} = sub { netout('ZMessage transmission took longer than an hour', 1); };
alarm 3600;

# get an SMTP mail relay to use
my $mailhost = shift;
unless (defined($mailhost) and $mailhost) {
  print STDERR basename($0) . ": no SMTP relay defined\n";
  netout('ZNo SMTP relay defined');
}
($mailhost) = $mailhost =~ m/^([\w\d\-\.]+)$/; # taint check - mail server hostname
my $smtp = Net::SMTP->new($mailhost, Timeout => 10, Debug => defined($debug) ? 1 : 0);
netout('ZConnection to SMTP relay seems problematic') unless defined ($smtp) and $smtp;
my $domain = $smtp->domain();

# initialise some variables.  $in holds the message (in memory)
my ($len, $in) = (0, '');

# set our filehandles to autoflush since netstrings aren't line buffered
select((select(STDOUT), $|=1)[0]);
select((select(STDIN), $|=1)[0]);

# read the length of the initial netstring from stdin
for (;;) {
  sysread (STDIN, $_, 1);
  last if $_ eq ':';
  netout ('DNon-digit in netstring length field', 1) unless m/^\d+$/;
  $len = ($len * 10) + $_;
}

# read the data portion ($len bytes) of the netstring from stdin
sysread (STDIN, $in, $len);

# be pedantic and check that the next character of stdin in the netstring terminator
sysread (STDIN, $_, 1);
netout ('DInvalid terminator in netstring', 1) unless $_ eq ',';

#
# At this point we have a parsed a valid netstring that hopefully consists
# of at least three concatinated netstrings.  We can now we can split up
# this (in memory) data into its components
#

# initialise the various message parts
my ($message, $sender, @recipients) = ('', '', ());

# make debugging easier
print STDERR "$in\n" if defined($debug);

# read the message itself
($in, $message) = getnetstr($in);

# and the envelope sender
($in, $sender) = getnetstr($in);

# there can be more than one recipient
while ($in ne '') {
  my ($out);
  ($in, $out) = getnetstr($in);
  push @recipients, $out;
}

#
# At this point we've validated the entire message and we have it in memory. 
# Now we can start an SMTP conversation.
#

# Set the envelope sender
# QMQP decline if the SMTP server barfs (for example, sender verify fails)
netout ('DSMTP server rejected sender in MAIL FROM', 1) unless
  $smtp->mail($sender);

# Set each of the envelope recipients
# QMQP decline on the first recipient the SMTP server doesn't like
foreach (@recipients) { 
  netout ("DSMTP server rejected recipient $_ in RCPT TO", 1) unless
    $smtp->recipient($_);
}

# Send the actual message
# QMQP decline unless the SMTP server accepts the message
netout ('DSMTP server rejected DATA') unless
  $smtp->data($message);

# pedantic clean up
$smtp->quit;

#
# At this point the SMTP server has agreed to queue the *entire* message
# with *all its recipients, so according to QMQP we can accept the message
# too.
#
netout ('KOK ' . $domain . ' accepted message via SMTP');

__END__

=head1 NAME

qmqp2smtp - QMQP to SMTP protocol translation

=head1 SYNOPSIS

tcpserver 0 628 qmqp2smtp.pl [-debug] some.smtp.relay

=head1 DESCRIPTION

qmqp2smtp is a simple, Perl based, QMQP to SMTP protocol translation
program.  It can be run as a daemon using the tcpserver program from
ucspi-tcp package (http://cr.yp.to/ucspi-tcp.html), as shown in the
synopsis.  The intention is to provide a fall-over means of delivering
e-mail if a valid qmqp server dies and, as such, could be listed in qmail's
qmqpservers control file.

Note that the QMQP specification states:

 "Note that QMQP is not a public service. Servers should not
  accept QMQP connections from unauthorised IP addresses."

This program makes no attempt to enforce this, instead
preferring to rely on the facilities provided by the tcpserver/tcprules
programs of the ucspi-tcp package.  Make sure you set up appropriate ACLs or
you'll become an open relay.

=head1 BUGS

The entire message is stored in memory before it is transmitted.  This might
cause problems on systems with low memory or per-user/per-process memory
limits.

=head1 AUTHOR

Guy Antony Halse <guy-ezmlm@rucus.net>
 

=head1 SEE ALSO

qmail(7), qmail-qmqpc(8)
 
http://cr.yp.to/proto/qmqp.html, http://cr.yp.to/proto/netstrings.txt
http://cr.yp.to/proto/8bittext.html, http://cr.yp.to/ucspi-tcp.html