#!/local/bin/perl

#
# Copyright (c) by Kirill Miazine <km@krot.org>
#
# This software is distributed under an ISC-style license, please see
# <http://km.krot.org/code/license.txt> for details.
#

package pipehack;

use warnings;
use strict;
use vars qw(@ISA);

use Net::Server::PreFork;
@ISA = qw(Net::Server::PreFork);

use Fcntl qw(:DEFAULT SEEK_SET);
use Data::Dumper;

### START EDIT
my $spool_dir = '/var/spool/exim/input';
my $socket = '/tmp/pipehack.sock';
my $pid_file = '/tmp/pipehack.pid';
my $exec = '/usr/bin/true';
### END EDIT

umask 0007;

__PACKAGE__->run(
    proto => 'unix',
    port => "$socket|unix",
    pid_file => $pid_file,
    min_servers => 1,
    min_spare_servers => 1,
    max_spare_servers => 2,
    max_servers => 10,
    max_requests => 100,
#    user => 1024,
#    group => 512,
    log_level => 0,
    background => 1,
    setsid => 1,
);

sub process_request {
    my $self = shift;
    my $sock = $self->{'server'}->{'client'};

    chomp(my $message_id = $sock->getline());
    chomp(my $local_part = $sock->getline());
    chomp(my $local_part_suffix = $sock->getline());
    chomp(my $domain = $sock->getline());

    my $msg = spool_message($spool_dir, $message_id);
    $sock->print("1\n"), return if !defined $msg;

    $ENV{'SENDER'} = $msg->{'return_path'};
    $ENV{'RECIPIENT'} = "$local_part$local_part_suffix\@$domain";
    $ENV{'EXTENSION'} = $local_part_suffix ? substr($local_part_suffix, 1) : '';

    local $SIG{'CHLD'} = 'DEFAULT';
    local $SIG{'PIPE'} = 'IGNORE';
    if (open my $child, '|-') {
        print $child "Return-path: $msg->{'return_path'}\n";
        print $child $_ for (@{$msg->{'headers'}}, "\n", @{$msg->{'body'}});
        close $child;
    } else {
        open STDOUT, '> /dev/null';
        open STDERR, '> /dev/null';
        exec $exec;
        exit;
    }

    my $exit = $? >> 8;
    $sock->print("$exit\n");
}

sub spool_message {
    my ($spool_dir, $message_id) = @_;
    my %msg;

    open my $hh, "< $spool_dir/$message_id-H" or return;
    open my $dh, "< $spool_dir/$message_id-D" or return;

=pod
    if (open my $th, "> /home/km/tmp/spool-$message_id") {
        my $buf;
        print $th "=== START -H ===\n";
        print $th $buf while (defined($buf = <$hh>));
        print $th "=== END -H ===\n\n";
        print $th "=== START -B ===\n";
        print $th $buf while (defined($buf = <$dh>));
        print $th "=== END -B ===\n\n";
        close $th;
    }

    seek $hh, 0, 0;
    seek $dh, 0, 0;
=cut

    my $tmp = <$hh>;

    chomp($tmp = <$hh>);
    @msg{qw(caller_name caller_uid caller_gid)} = split / /, $tmp, 3;

    chomp($msg{'return_path'} = <$hh>);
    $msg{'return_path'} =~ s/^<(.+)>$/$1/;

    chomp($tmp = <$hh>);
    @msg{qw(time_received warning_count)} = split / /, $tmp, 2;

    while (1) {
        chomp($tmp = <$hh>);
        if ($tmp =~ /^-acl (\d+) (\d+)/) {
            my ($num, $len) = ($1, $2 + 1);
            my $key = ($num < 10) ? 'acl_c' . $num : 'acl_m' . ($num - 10);
            read $hh, $tmp, $len;
            chomp($msg{$key} = $tmp);
            next;
        }
        last if $tmp !~ s/^-//;
        my ($key, $val) = split / /, $tmp, 2;
        $msg{$key} = $val;
    }

    while (1) {
        chomp($tmp = <$hh>);
        last if $tmp !~ /^[XYN][XYN]/
    }

    $msg{'recipients'} = [];
    for my $i (1 .. $tmp) {
        chomp($tmp = <$hh>);
        push @{$msg{'recipients'}}, $tmp;
    }

    $tmp = <$hh>;
    my $pos = tell $hh;

    my (@headers, @body);
    while (defined(my $line = <$hh>)) {
        $line =~ /^((\d+)([ BCFIPRST*]) )/ or next;
        $pos += length($1);
        my ($len, $char) = ($2, $3);
        seek $hh, $pos, SEEK_SET;
        read $hh, $tmp, $len;
        push @headers, $tmp if $char ne '*';
        $pos = tell $hh;
    }

    $tmp = <$dh>;
    while (defined(my $line = <$dh>)) {
        push @body, $line;
    }

    close $hh;
    close $dh;

    $msg{'headers'} = \@headers;
    $msg{'body'} = \@body;

=pod
    if (open my $th, ">> /home/km/tmp/spool-$message_id") {
        print $th "=== START DUMP ===\n";
        my $dump = Data::Dumper->Dump([\%msg], [qw(msg)]);
        print $th $dump;
        print $th "=== END DUMP ===\n\n";
        close $th;
    }
=cut

    return \%msg;
}

1;