# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Mail::Send
#   Author  : Scott Beck
#   CVS Info :                          
#   $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================

package GT::Mail::Send;

use strict;
use GT::Base;
use GT::Socket::Client;
use GT::Mail::POP3;
use GT::MD5;
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);

%SENDMAIL_ERRORS = (
    64 => 'EX_USAGE',
    65 => 'EX_DATAERR',
    66 => 'EX_NOINPUT',
    67 => 'EX_NOUSER',
    68 => 'EX_NOHOST',
    69 => 'EX_UNAVAILABLE',
    70 => 'EX_SOFTWARE',
    71 => 'EX_OSERR',
    72 => 'EX_OSFILE',
    73 => 'EX_CANTCREAT',
    74 => 'EX_IOERR',
    75 => 'EX_TEMPFAIL',
    76 => 'EX_PROTOCOL',
    77 => 'EX_NOPERM',
    78 => 'EX_CONFIG',

# This is for qmail-inject's version of sendmail
# Nice that they are different..
    111 => 'EX_TEMPFAIL',
    100 => 'EX_USAGE',
);

@ISA     = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0;
$ATTRIBS = {
    mail          => undef,
    host          => undef,
    port          => undef,
    ssl           => undef,
    from          => undef,
    path          => undef,
    flags         => undef,
    rcpt          => undef,
    user          => undef,
    pass          => undef,
    pbs_user      => undef,
    pbs_pass      => undef,
    pbs_host      => undef,
    pbs_port      => undef,
    pbs_auth_mode => undef,
    pbs_ssl       => undef,
    debug    => 0,
};
$ERRORS = {
    HOSTNOTFOUND     => "SMTP: server '%s' was not found.",
    CONNFAILED       => "SMTP: connect() failed. reason: %s",
    SERVNOTAVAIL     => "SMTP: Service not available: %s",
    SSLNOTAVAIL      => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
    COMMERROR        => "SMTP: Unspecified communications error: '%s'.",
    USERUNKNOWN      => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
    TRANSFAILED      => "SMTP: Transmission of message failed: %s",
    AUTHFAILED       => "SMTP: Authentication failed: %s",
    TOEMPTY          => "No To: field specified.",
    NOMSG            => "No message body specified",
    SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
    NOOPTIONS        => "No options were specified. Be sure to pass a hash ref to send()",
    NOTRANSPORT      => "Neither sendmail nor SMTP were specified!",
    SENDMAIL         => "There was a problem sending to Sendmail: (%s)",
    NOMAILOBJ        => "No mail object was specified.",
    EX_USAGE         => "Command line usage error",
    EX_DATAERR       => "Data format error",
    EX_NOINPUT       => "Cannot open input",
    EX_NOUSER        => "Addressee unknown",
    EX_NOHOST        => "Host name unknown",
    EX_UNAVAILABLE   => "Service unavailable",
    EX_SOFTWARE      => "Internal software error",
    EX_OSERR         => "System error (e.g., can't fork)",
    EX_OSFILE        => "Critical OS file missing",
    EX_CANTCREAT     => "Can't create (user) output file",
    EX_IOERR         => "Input/output error",
    EX_TEMPFAIL      => "Temp failure; user is invited to retry",
    EX_PROTOCOL      => "Remote error in protocol",
    EX_NOPERM        => "Permission denied",
    EX_CONFIG        => "Configuration error",
    EX_UNKNOWN       => "Sendmail exited with an unknown exit status: %s"
};
$CRLF = "\015\012";

sub init {
    my $self = shift;
    $self->set(@_);

# We need either a host or a path to sendmail and an email object
    $self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
    exists $self->{mail}           or return $self->error("NOMAILOBJ", "FATAL");

# Set debugging
    $self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;

# Default port for smtp
    if ($self->{host} and !$self->{port}) {
        $self->{port} = $self->{ssl} ? 465 : 25;
    }

# Default flags for sendmail
    elsif ($self->{path}) {
        ($self->{flags}) or $self->{flags} = '-t -oi -oeq';
        $self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
        (-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
    }
    return $self;
}

sub smtp_send {
# ---------------------------------------------------------------
# 
    my ($self, $sock, $cmd) = @_;

    if (defined $cmd) {
        print $sock "$cmd$CRLF";
        $self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
    }

    $_ = <$sock>;
    return if !$_;

    my $resp = $_;
    if (/^\d{3}-/) {
        while (defined($_ = <$sock>) and /^\d{3}-/) {
            $resp .= $_;
        }
        $resp .= $_;
    }
    $resp =~ s/$CRLF/\n/g;
    $self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
    return $resp;
}

sub smtp {
# ---------------------------------------------------------------
# Opens a smtp port and sends the message headers.
#
    my $self = shift;

    ref $self or $self = $self->new(@_);

    if ($self->{ssl}) {
        $HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
        $HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
    }

    if ($self->{pbs_host}) {
        my $pop = GT::Mail::POP3->new(
            host      => $self->{pbs_host},
            port      => $self->{pbs_port},
            user      => $self->{pbs_user},
            pass      => $self->{pbs_pass},
            auth_mode => $self->{pbs_auth_mode},
            ssl       => $self->{pbs_ssl},
            debug     => $self->{debug}
        );
        my $count = $pop->connect();
        if (!defined($count)) {
            $self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
        }
        else {
            $pop->quit();
        }
    }

    my $sock = GT::Socket::Client->open(
        host => $self->{host},
        port => $self->{port},
        ssl => $self->{ssl}
    ) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);

    local $SIG{PIPE} = 'IGNORE';
    local $_;

# Get the server's greeting message
    my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
    return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;

    $resp = $self->smtp_send($sock, "EHLO localhost") or return $self->error('COMMERROR', 'WARN');
    if ($resp =~ /^[45]/) {
        $resp = $self->smtp_send($sock, "HELO localhost") or return $self->error('COMMERROR', 'WARN');
        return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
    }

# Authenticate if needed
    if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
        my $server = uc $1;
        my $method = '';
# These are the authentication types that are supported, ordered by preference
        for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
            if ($server =~ /$m/) {
                $method = $m;
                last;
            }
        }
        if ($method eq 'CRAM-MD5') {
            $resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;

            my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
            $challenge = decode_base64($challenge);
            my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));

            $resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
        }
        elsif ($method eq 'PLAIN') {
            my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
            $resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
        }
        elsif ($method eq 'LOGIN') {
            $resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;

            $resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;

            $resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
            return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
        }
    }

# We use return-path so the email will bounce to who it's from, not the user
# doing the sending.
    my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
    $from = $self->extract_email($from) || '';

    $self->debug("Sending from: <$from>") if $self->{debug} == 1;
    $resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
    return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;

    my $found_valid = 0;
    my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
    for my $to (@tos) {
        next unless $to and my $email = $self->extract_email($to);

        $found_valid++;
        $self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
        $resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
        return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
    }
    $found_valid or return $self->error('TOEMPTY', 'FATAL');

    $resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
    return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;

# Remove Bcc from the headers.
    my @bcc = $self->{mail}->{head}->delete('bcc');

    my $mail = $self->{mail}->to_string;

# SMTP needs any leading .'s to be doubled up.
    $mail =~ s/^\./../gm;

# Print the mail body.
    $resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
    return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;

# Add them back in.
    foreach my $bcc (@bcc) {
        $self->{mail}->{head}->set('bcc', $bcc);
    }

# Close the connection.
    $resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
    close $sock;
    return 1;
}

sub sendmail {
# ---------------------------------------------------------------
# Sends a message using sendmail.
#
    my $self = shift;

    ref $self or $self = $self->new(@_);

# Get a filehandle, and open pipe to sendmail.
    my $s = \do{ local *FH; *FH };

# If the email address is safe, we set the envelope via -f so bounces are handled properly.
    my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
    my $envelope = '';
    if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
        $envelope = "-f $1";
    }
    elsif ($from eq '<>' or $from eq '') {
        $envelope = "-f ''";
    }
    open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
    $self->{mail}->write($s);
    return 1 if close $s;
    my $exit_value  = $? >> 8;

    my $code;
    if (exists $SENDMAIL_ERRORS{$exit_value}) {
        $code = $SENDMAIL_ERRORS{$exit_value};
    }
    else {
        $code = 'EX_UNKNOWN';
    }
    if ($code eq 'EX_TEMPFAIL') {
        return 1;
    }
    return $self->error($code, "WARN", $exit_value);
    return 1;
}

sub extract_email {
# -----------------------------------------------------------------------------
# Takes a field, returns the e-mail address contained in that field, or undef
# if no e-mail address could be found.
#
    shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);

    my $to = shift;

# We're trying to get down to the actual e-mail address.  To do so, we have to
# remove quoted strings and comments, then extract the e-mail from whatever is
# left over.  
    $to =~ s/"(?:[^"\\]|\\.)*"//g;
    1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;

    my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;

    return $email;
}

sub encode_base64 {
    my $res = '';
    pos($_[0]) = 0; # In case something has previously adjusted pos
    while ($_[0] =~ /(.{1,45})/gs) {
        $res .= substr(pack(u => $1), 1, -1);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;

    my $padding = (3 - length($_[0]) % 3) % 3;
    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
    $res;
}

sub decode_base64 {
    my $str = shift;
    my $res = '';

    $str =~ tr|A-Za-z0-9+=/||cd;

    $str =~ s/=+$//;
    $str =~ tr|A-Za-z0-9+/| -_|;
    return '' unless length $str;

    my $uustr = '';
    my ($i, $l);
    $l = length($str) - 60;
    for ($i = 0; $i <= $l; $i += 60) {
        $uustr .= "M" . substr($str, $i, 60);
    }
    $str = substr($str, $i);
    # and any leftover chars
    if ($str ne "") {
        $uustr .= chr(32 + length($str) * 3 / 4) . $str;
    }
    return unpack("u", $uustr);
}

sub hmac_md5_hex {
    my ($challenge, $data) = @_;

    GT::MD5::md5($challenge) if length $challenge > 64;

    my $ipad = $data ^ (chr(0x36) x 64);
    my $opad = $data ^ (chr(0x5c) x 64);

    return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
}

1;

__END__

=head1 NAME

GT::Mail::Send - Module to send emails

=head1 SYNOPSIS

    use GT::Mail::Send;
    
    # $mail_object must be a GT::Mail object
    my $send = new GT::Mail::Send (
        mail  => $mail_object,
        host  => 'smtp.gossamer-threads.com',
        debug => 1
    );

    $send->smtp or die $GT::Mail::Send::error;

=head1 DESCRIPTION

GT::Mail::Send is an object interface to sending email over either
SMTP or Sendmail. This module is used internally to GT::Mail.

=head2 new - Constructor method

Returns a new GT::Mail::Send object. You must specify either the smtp host
or a path to sendmail. This method is inherented from GT::Base. The arguments
can be in the form of a hash or hash ref.

=over 4

=item debug

Sets the debug level for this instance of GT::Mail::Send.

=item mail

Specify the mail object to use. This must be a GT::Mail object and must contain
an email, either passed in or parsed in.

=item host

Specify the host to use when sending by SMTP.

=item port

Specify the port to use when sending over SMTP. Defaults to 25.

=item path

Specify the path to sendmail when sending over sendmail. If the binary passed in
does not exist, undef will be returned and the error set in GT::Mail::Send::error.

=item flags

Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
guilde for sendmail for more info on the parameters to sendmail.

=back

=head2 smtp

Class or instance method. Sends the passed in email over SMTP. If called as a class
method, the parameters passed in will be used to call new(). Returns true on error,
false otherwise.

=head2 sendmail

Class or instance method. Send the passed in email to sendmail using the specified
path and flags. If called as a class method all additional arguments are passed to the
new() method. Returns true on success and false otherwise.

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $

=cut


