#
# This file is best read with ``perldoc writing.pod''
#

### 
# Conventions:
#  plugin names:  F<myplugin>, F<qpsmtpd-async>
#  constants:     I<LOGDEBUG>
#  smtp commands, answers: B<HELO>, B<250 Queued!>
#
# Notes: 
#  * due to restrictions of some POD parsers, no C<<$object->method()>>
#    are allowed, use C<$object-E<gt>method()> 
# 

=head1 Writing your own plugins

This is a walk through a new queue plugin, which queues the mail to a (remote)
QMQP-Server.

First step is to pull in the necessary modules

 use IO::Socket;
 use Text::Netstring qw( netstring_encode 
                         netstring_decode 
                         netstring_verify 
                         netstring_read );

We know, we need a server to send the mails to. This will be the same 
for every mail, so we can use arguments to the plugin to configure this 
server (and port).

Inserting this static config is done in C<register()>:

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

    die "No QMQP server specified in qmqp-forward config"
      unless @args;

    $self->{_qmqp_timeout} = 120;

    if ($args[0] =~ /^([\.\w_-]+)$/) {
      $self->{_qmqp_server} = $1;
    }
    else {
      die "Bad data in qmqp server: $args[0]";
    }

    $self->{_qmqp_port} = 628;
    if (@args > 1 and $args[1] =~ /^(\d+)$/) {
      $self->{_qmqp_port} = $1;
    }

    $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") 
      if (@args > 2);
  }

We're going to write a queue plugin, so we need to hook to the I<queue>
hook.

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

    $self->log(LOGINFO, "forwarding to $self->{_qmqp_server}:"
                       ."$self->{_qmqp_port}");

The first step is to open a connection to the remote server.

   my $sock = IO::Socket::INET->new(
                 PeerAddr => $self->{_qmqp_server},
                 PeerPort => $self->{_qmqp_port},
                 Timeout  => $self->{_qmqp_timeout},
                 Proto    => 'tcp')
      or $self->log(LOGERROR, "Failed to connect to "
                      ."$self->{_qmqp_server}:"
                      ."$self->{_qmqp_port}: $!"),
        return(DECLINED);
    $sock->autoflush(1);

=over 4

=item *

The client starts with a safe 8-bit text message. It encodes the message
as the byte string C<firstline\012secondline\012 ... \012lastline>. (The
last line is usually, but not necessarily, empty.) The client then encodes
this byte string as a netstring. The client also encodes the envelope
sender address as a netstring, and encodes each envelope recipient address
as a netstring.

The client concatenates all these netstrings, encodes the concatenation
as a netstring, and sends the result.

(from L<http://cr.yp.to/proto/qmqp.html>)

=back

The first idea is to build the package we send, in the order described
in the paragraph above:

  my $message = $transaction->header->as_string;
  $transaction->body_resetpos;
  while (my $line = $transaction->body_getline) {
    $message .= $line;
  }
  $message  = netstring_encode($message);
  $message .= netstring_encode($transaction->sender->address);
  for ($transaction->recipients) {
    push @rcpt, $_->address;
  }
  $message .= join "", netstring_encode(@rcpt);
  print $sock netstring_encode($message)
    or do {
      my $err = $!;
      $self->_disconnect($sock);
      return(DECLINED, "Failed to print to socket: $err");
    };

This would mean, we have to hold the full message in memory... Not good 
for large messages, and probably even slower (for large messages).

Luckily it's easy to build a netstring without the help of the
C<Text::Netstring> module if you know the size of the string (for more
info about netstrings see L<http://cr.yp.to/proto/netstrings.txt>).

We start with the sender and recipient addresses:

  my ($addrs, $headers, @rcpt);
  $addrs = netstring_encode($transaction->sender->address);
  for ($transaction->recipients) {
    push @rcpt, $_->address;
  }
  $addrs .= join "", netstring_encode(@rcpt);

Ok, we got the sender and the recipients, now let's see what size the
message is.

  $headers   = $transaction->header->as_string;
  my $msglen = length($headers) + $transaction->body_length;

We've got everything we need. Now build the netstrings for the full package
and the message.

First the beginning of the netstring of the full package

  # (+ 2: the ":" and "," of the message's netstring)
  print $sock ($msglen + length($msglen) + 2 + length($addrs))
               .":"
               ."$msglen:$headers" ### beginning of messages netstring
    or do { 
      my $err = $!;
      $self->_disconnect($sock);
      return(DECLINED, 
             "Failed to print to socket: $err");
    };

Go to beginning of the body

  $transaction->body_resetpos;

If the message is spooled to disk, read the message in
blocks and write them to the server

  if ($transaction->body_fh) {
    my $buff;
    my $size = read $transaction->body_fh, $buff, 4096;
    unless (defined $size) {
      my $err = $!;
      $self->_disconnect($sock);
      return(DECLINED, "Failed to read from body_fh: $err");
    }
    while ($size) {
      print $sock $buff
        or do { 
          my $err = $!;
          $self->_disconnect($sock);
          return(DECLINED, "Failed to print to socket: $err");
        };

      $size = read $transaction->body_fh, $buff, 4096;
      unless (defined $size) {
        my $err = $!;
        $self->_disconnect($sock);
        return(DECLINED, 
               "Failed to read from body_fh: $err");
      }
    }
  }

Else we have to read it line by line ...

  else { 
    while (my $line = $transaction->body_getline) {
      print $sock $line
        or do { 
          my $err = $!;
          $self->_disconnect($sock);
          return(DECLINED, "Failed to print to socket: $err");
        };
    }
  }

Message is at the server, now finish the package.

  print $sock ","    # end of messages netstring
             .$addrs # sender + recpients
             .","    # end of netstring of 
                     #   the full package
    or do { 
      my $err = $!;
      $self->_disconnect($sock);
      return(DECLINED, 
             "Failed to print to socket: $err");
    };

We're done. Now let's see what the remote qmqpd says...


=over 4

=item *

(continued from L<http://cr.yp.to/proto/qmqp.html>:)

The server's response is a nonempty string of 8-bit bytes, encoded as a
netstring.

The first byte of the string is either K, Z, or D. K means that the
message has been accepted for delivery to all envelope recipients. This
is morally equivalent to the 250 response to DATA in SMTP; it is subject
to the reliability requirements of RFC 1123, section 5.3.3. Z means
temporary failure; the client should try again later. D means permanent
failure.

Note that there is only one response for the entire message; the server
cannot accept some recipients while rejecting others.

=back


    my $answer = netstring_read($sock);
    $self->_disconnect($sock);

    if (defined $answer and netstring_verify($answer)) {
      $answer = netstring_decode($answer);

      $answer =~ s/^K// and return(OK,
                                 "Queued! $answer");
      $answer =~ s/^Z// and return(DENYSOFT, 
                                 "Deferred: $answer");
      $answer =~ s/^D// and return(DENY,
                                 "Denied: $answer");
    }

If this is the only F<queue/*> plugin, the client will get a 451 temp error:

    return(DECLINED, "Protocol error");
  }

  sub _disconnect {
    my ($self,$sock) = @_;
    if (defined $sock) {
      eval { close $sock; };
      undef $sock;
    }
  }

=cut

# vim: ts=2 sw=2 expandtab