#! /usr/bin/perl -w
#
# bssmtp: a better version of sSMTP
# Copyright (c) 2001 Hugo Haas <hugo@larve.net>
#
# This is an early alpha version. USE IT AT YOUR OWN RISK.
# This software comes with no warranty. The author cannot be held responsible
# for any mail lost, or any other damage.
#
# This software is distributed under the GNU General Public License version 2.
#
# $Id: bssmtp 1360 2001-06-19 11:34:38Z hugo $

use strict;

use Mail::Header;
use Mail::Address;
use Net::SMTP;
#use MIME::Entity;
use XML::Parser;
use XML::Dumper;
use Sys::Syslog qw(:DEFAULT setlogsock);
use POSIX qw(strftime);

# Configuration parameters
my %config = ( version => 'pre0.3',
               etc_dir => '/home/hugo/ssmtp/etc',
               verbose => 0,
               debug => 0,
               opt_t => 0,
               queue_only => 0,
               list_queue => 0,
               process_queue => 0,
               timeout => 120);

# These settings are message specific
my @pw = getpwuid($<);
$pw[6] =~ s/,.*//;
my %message = (uid => $<,
               from => $pw[0],
               fullname => $pw[6],
               bits => 8,
               time => time());
undef(@pw);

# SMTP variables
my %smtp;

# Parse command line
&parse_commandline();

# Escape full name
$message{fullname} =~ s/\"/\\\"/g;

# Parse config
&parse_config();

# Change directory to spool directory
die "Spool directory not specified!\n" if (!defined($config{spool}));
chdir($config{spool}) || die "Cannot enter spool directory: $!";

# Check sender address
unless ($message{from} =~ m/\@/) {
    $message{from} .= '@'.$config{domain};
}

# Do the job
if ($config{list_queue}) {
    &list_queue();
    exit(0);
}

if ($config{process_queue}) {
    &process_queue();
} else {
    &open_syslog();
    &send_message();
}

# Close the SMTP connection in case one is opened
if (defined($smtp{connection})) {
    $smtp{connection}->quit();
}

# We are done!
exit(0);

###############################################################################

########################
# Command line parsing #
########################

sub parse_commandline() {
    if ($0 =~ m/mailq$/) {
        $config{list_queue} = 1;
    }
    my $arg;
    my $address_only = 0;
    while (@ARGV) {
        $_ = shift(@ARGV);
        if ($address_only) {
            push(@{$message{recipients}}, $_);
            next;
        }
        if ($_ eq '--') {
            $address_only = 1;
        } elsif ($_ eq '-V') {
            print "bsSMTP version $config{version}\n";
            exit(0);
        } elsif ($_ eq '-v') {
            $config{verbose} = 1;
        } elsif ($_ eq '-t') {
            $config{opt_t} = 1;
        } elsif ($_ eq '-bp') {
            $config{list_queue} = 1;
        } elsif ($_ eq '-q') {
            $config{process_queue} = 1;
        } elsif ($_ eq '-B7BIT') {
            $message{bits} = 7;
        } elsif ($_ eq '-B8BITMIME') {
            $message{bits} = 8;
        } elsif ($_ eq '-odq') {
            $config{queue_only} = 1;
        } elsif (m/^-f(.*)$/) {
            if ($1 eq '') {
                $message{from} = shift(@ARGV);
            } else {
                $message{from} = $1;
            }
        } elsif (m/^-F(.*)$/) {
            if ($1 eq '') {
                $message{fullname} = shift(@ARGV);
            } else {
                $message{fullname} = $1;
            }
        } elsif (m/^-d(.*)$/) {
            if ($1 eq '') {
                $config{debug} = shift(@ARGV);
            } else {
                $config{debug} = $1;
            }
        } elsif (! m/^-/) {
            push(@{$message{recipients}}, $_);
        }
    }
}

###############################
# Configuration files parsing #
###############################

sub get_profilename() {
    my ($f) = @_;

    open(F, "< $f") || return;
    my $p = <F>;
    close(F);
    chomp($p);
    return($p);
}

sub parse_config() {
    my ($f) = @_;

    my $loc;
    if (defined($f)) {
        $loc = 1;
        $f = "$config{etc_dir}/local.$f";
    } else {
        $loc = 0;
        $f = "$config{etc_dir}/config";
    }

    &debug('Parsing configuration file');
    if (! open(CONFIG, "< $f")) {
        if ($loc) {
            return;
        } else {
            die "Cannot open configuration at $f: $!";
        }
    }
    while(<CONFIG>) {
        next if (m/^\#/);
        next if (m/^\w*$/);
        chop;
        my @configline = split('=', $_, 2);
        &debug("Config: $configline[0] = $configline[1]");
        $config{$configline[0]} = $configline[1];
        if ($configline[0] eq 'mailhost') {
            if ($configline[1] =~ m/:/) {
                my @host = split(/:/, $configline[1], 2);
                $config{mailhost} = $host[0];
                $config{port} = $host[1];
            } else {
                $config{port} = 25;
            }
        }
    }
    close(CONFIG);
    # Now see if we can load a local configuration
    return if $loc;
    &debug('Trying to find a local profile');
    my $profile;
    if (defined($ENV{BSSMTP})) {
        $profile = $ENV{BSSMTP};
    } elsif (-r "$ENV{HOME}/.bssmtp") {
        $profile = &get_profilename("$ENV{HOME}/.bssmtp");
    } elsif (-r "$config{etc_dir}/local") {
        $profile = &get_profilename("$config{etc_dir}/local");
    }
    if (defined($profile)) {
        &debug("Using $profile");
        &parse_config($profile);
    }
}

###################################
# Function for debugging purposes #
###################################

sub debug() {
    return if (! $config{debug});
    print(STDERR ': ' . $_[0] . "\n");
}

#####################
# Locking functions #
#####################

sub lock() {
    my ($id) = @_;
    &debug("Attempting to lock message $id");
    while (-f "l-$id") {
        &debug('Lock exists... sleeping');
        sleep(1);
    }
    open(LOCK, "> l-$id");
    close(LOCK);
}

sub unlock() {
    my ($id) = @_;
    &debug("Unlocking message $id");
    unlink("l-$id");
}

#############################
# Syslog handling functions #
#############################

sub open_syslog() {
    setlogsock('unix');
    openlog('bssmtp', 'pid', 'daemon');
}

sub log() {
    syslog('notice|mail', @_);
}

sub log_status() {
    my ($id, $status, $from, $rec, $message) = @_;

    &log('%s: %s; from=<%s> to=<%s> relay=<%s:%s> (%s)',
         $id,
         $status,
         $from,
         $rec,
         $config{mailhost},
         $config{port},
         $message);
}

sub log_event() {
    my ($id) = @_;

    if (defined($smtp{succeeded_rec})) {
        &log_status($id,
                    'delivered',
                    $smtp{from},
                    join(',', @{$smtp{succeeded_rec}}),
                    $smtp{message});
    }
    if (defined($smtp{failed_rec})) {
        &log_status($id,
                    'failed',
                    $smtp{from},
                    join(',', @{$smtp{failed_rec}}),
                    $smtp{message});
    }
}

#########################################
# Get the list of messages in the queue #
#########################################

sub get_queued_messages() {
    my @queued;
    &debug('Listing spool directory');
    while (<*>) {
        next unless (/^c-/);
        s/^c-//;
        push (@queued, $_);
    }
    return(@queued);
}

##########################
# Queue listing function #
##########################

sub display_queue_information() {
    my ($id, $size, $qtime, $sender, @recipients) = @_;
    printf("%-8s %8s %-16s %-41s\n", $id, $size, $qtime, $sender);
    foreach $_ (@recipients) {
        printf(' 'x35 ."%41s\n", $_);
    }
}

sub display_message_information() {
    my ($id) = @_;

    my $control = &get_control($id);
    my $time = strftime("%a %b %e %H:%M", localtime($control->{time}));
    &display_queue_information($id, (stat("m-$id"))[7],
                               $time, $control->{from},
                               @{$control->{recipients}});
}

sub list_queue() {
    my @queued = &get_queued_messages();
    if ($#queued == -1) {
        print("Mail queue is empty.\n");
    } else {
        print("\t\tMail Queue (" .
              ($#queued+1) .
              ' request' .
              (($#queued) ? 's' : '') .
              ")\n");
        &display_queue_information('--Q-ID--',
                                   '--Size--',
                                   '-----Q-Time-----',
                                   '------------Sender/Recipient------------',
                                   ());
        foreach $_ (@queued) {
            &display_message_information($_);
        }
    }
}

####################
# Queue processing #
####################

sub process_queue() {
    &debug('Trying to send the queued messages');
    # @@@@ Test age of the message
    my @queued = &get_queued_messages();
    if ($#queued > -1) {
        &open_syslog();
    }
    foreach $_ (@queued) {
        &send_message($_, ());
    }
}

#######################################################
# Send a message                                      #
# If an id is given, send the message from the spool  #
#######################################################

sub send_message() {
    my ($id) = @_;

    if (!defined($id)) {
        &debug('Sending new message');
        if ( (! $config{opt_t}) &&
             (! defined($message{recipients})) ){
            print(STDERR "No recipient specified.\n");
            exit(-1);
        }
# Put message in the spool
        $id = &gen_id();
        &lock($id);
        &queue_message($id);
        my $control = &gen_control($id);
        &store_control($id, \%message);
        if ($#{$message{recipients}} == -1) {
            print(STDERR "No recipient found.\n");
            &unqueue($id);
            &unlock($id);
            exit(-1);
        }
    } else {
        &debug('Sending queued message '.$id);
    }

    if (! $config{queue_only}) {
# Send the message
        if (&send_queued_message($id) || ($smtp{error_msg} ne '')) {
            # Ouch, error...
            &log_event($id);
            &debug('Oops, got an error.');
            if (! defined($smtp{connection})) {
                goto unlock;
            }
            my $code = $smtp{connection}->code();
            $smtp{connection}->reset();
            &debug('Code: '.$code);
            &debug('Message: '.$smtp{message});
            if ($code =~ m/^5/) {
                &debug('Fatal error!');
                # Build an email with the error
                $smtp{error_msg} .= "Could not deliver message:\n";
                $smtp{error_msg} .= 'Code: '.$code."\n";
                $smtp{error_msg} .= 'Message: '.$smtp{message}."\n";
            } elsif ($code =~ m/^4/) {
                &debug('Non fatal error. Mail still queued');
            }
            if ($smtp{error_msg}) {
                # Send an email with the report @@@@@
                my $mail = MIME::Entity->build(From => 'me@myhost.com',
                                               To => "$message{from}",
                                               Subject  => 'Mail delivery problem',
                                               Data => $smtp{error_msg});
                $mail->attach(Path => "m-$id",
                              Type => 'message/rfc822',
                              Description => 'Message');
                # Output it:
                $mail->print(\*STDOUT);
                # Unqueue the message
                &unqueue($id);
            }
        } else {
            &log_event($id);
            &unqueue($id);
        }
    }
      unlock:
        &unlock($id);
}

#######################
# Generate a spool id #
#######################

sub gen_id() {
    my $id;
    &debug('Generating a message id');
    do {
        $id = int(rand(99999999));
        &debug("Trying $id...");
    } until(! (-f "c-$id" || -f "m-$id" || -f "l-$id") );
    &debug('ok');
    return($id);
}

#####################
# Queue the message #
#####################

sub queue_message() {
    my ($id) = @_;

    &debug('Writing message to spool');
    open(MESSAGE, "> m-$id") || die "Failed to open message file: $!";
    # Add the routing information here
    printf(MESSAGE "Received: by %s (bssmtp %s) id <%s>;\n\t%s %s\n",
           $config{hostname}, $config{version}, $id,
           strftime("%a, %d %b %Y %H:%M:%S %z", localtime));
    # Build an array with the headers
    my @headers;
    # Check the headers
    my $has_from = 0;
    my $has_mid = 0;
    my $found_header_separator = 0;
    while(<STDIN>) {
        if (m/^From:/i) {
            $has_from = 1;
        }
        if (m/^Message-Id:/i) {
            $has_mid = 1;
        }    
        if (m/^$/) {
            $found_header_separator = 1;
            last;
        } else {
            push(@headers, $_);
        }
    }
    # Add a From field if needed
    if (! $has_from) {
        my $from_field = $message{from};
        if ($message{fullname} ne '') {
            $from_field = '"'.$message{fullname}.'" <'.$from_field.'>';
        }
        print(MESSAGE "From: $from_field\n");
    }
    # If a message-id was missing, add it
    if (! $has_mid) {
        print(MESSAGE "Message-Id: <" .
              strftime("%Y%m%d%H%M%S", localtime) .
              ".$id\@$config{domain}>\n");
    }
    if (! $found_header_separator) {
        # No header found
        print(MESSAGE "\n");
    }
    print(MESSAGE join('', @headers));
    if ($found_header_separator) {
        print(MESSAGE "\n");
        # Copy the body
         while(<STDIN>) {
            print(MESSAGE $_);
        }
    }
    close(MESSAGE);
}

#####################
# Unqueue a message #
#####################

sub unqueue() {
    my ($id) = @_;

    &debug("Removing c-$id and m-$id");
    unlink("c-$id");
    unlink("m-$id");
}

#####################################
# Get the content of a control file #
#####################################

sub get_control() {
    my ($id) = @_;

    &debug("Opening control file for message $id");
    open(CONTROL, "c-$id") || die "Failed to open control file: $!";
    my $def;
    while (<CONTROL>) {
        $def .= $_;
    }
    close(CONTROL);
    my $d = new XML::Dumper;
    my $p = XML::Parser->new(Style => 'Tree');
    my $t = $p->parse($def);
    my $control = $d->xml2pl($t);
    return($control);
}

###########################
# Store control structure #
###########################

sub store_control() {
    my ($id, $control) = @_;
    &debug("Opening control file m-$id");
    open(CONTROL, "> c-$id") || die "Failed to open control file: $!";
#    my $d = Data::Dumper->new([$control]);
#    $d->Varname('control');
#    $d->Terse(1);
#    $d->Purity(1);
#    $d->Deepcopy(1);
#    print(CONTROL $d->Dump());
    my $d = new XML::Dumper;
    print(CONTROL $d->pl2xml($control));
    close(CONTROL);
}

######################################################################
# Generate a control file knowing the id of the message in the spool #
######################################################################

sub concat_recipients() {
    my ($first, $second, @rest) = @_;

    my $recipients;
    if (defined($first)) {
        if (defined($second)) {
            $recipients = $first . ', '. $second;
        } else {
            $recipients = $first;
        }
    } else {
        if (defined($second)) {
            $recipients = $second;
        }
    }
    if (@rest) {
        &concat_recipients($recipients, @rest);
    } else {
        return($recipients);
    }
}

sub gen_control() {
    my ($id) = @_;

    my @recipients;
    if ($config{opt_t}) {
        &debug("Opening the message file m-$id");
        open(MESSAGE, "< m-$id") || die "Failed to open the message: $!";
        my $header = new Mail::Header(\*MESSAGE);
        close(MESSAGE);
        &debug('Extracting the email address from the recipients.');
        $header->unfold();
        @recipients =
          Mail::Address->parse(&concat_recipients($header->get('To'),
                                                  $header->get('Cc'),
                                                  $header->get('Bcc')));
    }
    my $addr;
    my @r;
    if (defined($message{recipients})) {
        @r = @{$message{recipients}};
    }
    foreach $addr (@recipients) {
        push(@r, $addr->address());
    }
    $message{recipients} = ();
    foreach $addr (@r) {
        unless ($addr =~ m/\@/) {
            $addr .= '@'.$config{domain};
        }
        &debug('Recipient: '. $addr);
        push(@{$message{recipients}}, $addr);
    }
}

########################
# Send a queue message #
########################

sub send_queued_message() {
    my ($id) = @_;

    $smtp{message} = '';
    $smtp{error_msg} = '';
    my $control = &get_control($id);
    $smtp{from} = $control->{from};
    $smtp{succeeded_rec} = ();
    $smtp{failed_rec} = $control->{recipients};
    &debug('Recipients: '.join(', ', @{$control->{recipients}}));
    # Make sure that there is a connection to the mail relay
    if (!defined($smtp{connection})) {
        $smtp{connection} = Net::SMTP->new($config{mailhost},
                                           Port => $config{port},
                                           Debug => $config{verbose},
                                           Hello => $control->{hostname},
                                           Timeout => $config{timeout});
        if (! defined($smtp{connection})) {
            $smtp{message} = "Could not connect to SMTP server $config{mailhost}";
            &debug($smtp{message});
            return(-1);
        }
    }
    # Initiate the mail delivery
    if (! $smtp{connection}->mail($message{from},
                                  Bits => $control->{bits})) {
        $smtp{message} = $smtp{connection}->message();
        return(-1);
    }
    # List the recipients
    my $recipient;
    my @rec_pending;
    $smtp{failed_rec} = ();
    foreach $recipient (@{$control->{recipients}}) {
        if (!$smtp{connection}->recipient($recipient)) {
            &debug("Could not deliver message to $recipient");
            push(@{$smtp{failed_rec}}, $recipient);
            &log_status($id, 'failed', $control->{from}, $recipient,
                        $smtp{connection}->message());
            # Fatal error?
            if ($smtp{connection}->code() =~ m/^5/) {
                $smtp{error_msg} .= 'Fatal error: '.$recipient."\n";
                $smtp{error_msg} .= 'Message: ' .
                                    $smtp{connection}->code() .
                                    ' ' .
                                    $smtp{connection}->message()."\n";
            } else {
                push(@rec_pending, $recipient);
            }
        } else {
            push(@{$smtp{succeeded_rec}}, $recipient);
        }
    }
    if (! defined($smtp{succeeded_rec})) {
        if (($#rec_pending > -1) &&
            ($#{$control->{recipients}} != $#rec_pending)) {
            my $new_control = $control;
            $new_control->{recipients} = @rec_pending;
            &store_control($id, $new_control);
        }
        $smtp{message} = 'Could not send message to any recipient';
        return(-1);
    }
    # Send the data
    if (!$smtp{connection}->data()) {
        $smtp{message} = $smtp{connection}->message();
        $smtp{succeeded_rec} = ();
        $smtp{failed_rec} = $control->{recipients};
        return(-1);
    }
    &debug("Opening the message file m-$id");
    open(MESSAGE, "m-$id") || die "Failed to open the message: $!";
    while(<MESSAGE>) {
        $smtp{connection}->datasend($_);
    }
    close(MESSAGE);
    if (!$smtp{connection}->dataend()) {
        $smtp{message} = $smtp{connection}->message();
        $smtp{succeeded_rec} = ();
        $smtp{failed_rec} = $control->{recipients};
        return(-1);
    }
    # We were successful, woohoo!
    # If there are still recipients to deliver mail to, put them back in the
    # control file
    if ($#rec_pending > -1) {
        my $new_control = $control;
        $new_control->{recipients} = @rec_pending;
        &store_control($id, $new_control);
    }
    my @msgs = split(/\n/, $smtp{connection}->message());
    $smtp{message} = $msgs[1];
    return(0);
}