Email and local delivery support added.
This commit is contained in:
parent
d84c784ab9
commit
0aa8cda126
@ -126,4 +126,5 @@ sub load_transport_module {
|
||||
return $self -> {"module"} -> load_module($modname -> [0]);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
@ -337,6 +337,47 @@ sub get_sendable_messages {
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Delivery
|
||||
|
||||
## @method $ deliver_queue($try_failed)
|
||||
# Attempt to deliver queued messages that have not yet been sent. This will invoke
|
||||
# the transport modules in turn, fetching sendable messages and trying to send them
|
||||
#
|
||||
# @param try_failed If this is set to true, transport modules will try to resend
|
||||
# messages that previously failed to send.
|
||||
sub deliver_queue {
|
||||
my $self = shift;
|
||||
my $try_failed = shift;
|
||||
|
||||
# Go through the list of transports, fetching the messages that can be sent by
|
||||
# that transport and try to send them.
|
||||
my $transports = $self -> get_transports();
|
||||
foreach my $transport (@{$transports}) {
|
||||
my $messages = $self -> get_sendable_messages($transport -> {"id"}, $try_failed)
|
||||
or return undef;
|
||||
|
||||
if(scalar(@{$messages})) {
|
||||
# Load the transport...
|
||||
$transport -> {"module"} = $self -> load_transport_module($transport -> {"id"})
|
||||
or return $self -> self_error("Transport loading failed: ".$transport -> {"module"} -> {"errstr"});
|
||||
|
||||
# Try to deliver each sendable message
|
||||
foreach my $message (@{$messages}) {
|
||||
my $sent = $transport -> {"module"} -> deliver($message);
|
||||
|
||||
# Store the send status for this transport
|
||||
$self -> update_status($message -> {"id"},
|
||||
$transport -> {"id"},
|
||||
$sent ? "sent" : "failed",
|
||||
$sent ? undef : $transport -> {"errstr"})
|
||||
or return undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Marking of various sorts
|
||||
|
||||
|
||||
44
Message/Transport.pm
Normal file
44
Message/Transport.pm
Normal file
@ -0,0 +1,44 @@
|
||||
## @file
|
||||
# This file contains the implementation of the base Message Transport class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program is free software: you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation, either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class Message::Transport
|
||||
# This is the 'base' class for the Message::Transport modules. It provides
|
||||
# any functionality that needs to be shared between the Message::Transport::*
|
||||
# modules.
|
||||
package Message::Transport;
|
||||
use strict;
|
||||
use base qw(Message);
|
||||
|
||||
# ============================================================================
|
||||
# Delivery
|
||||
|
||||
## @method $ deliver($message)
|
||||
# Attempt to deliver the specified message to its recipients. This function
|
||||
# does not actually do anything in the Message::Transport class - it must
|
||||
# be overridden in subclasses to actually perform message delivery.
|
||||
#
|
||||
# @param message A reference to hash containing the message data.
|
||||
# @return true if the message is sent successfully, undef if not.
|
||||
sub deliver {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
|
||||
return $self -> self_error("Attempt to send message '".$message -> {"id"}."' through transport ".ref($self)." with no deliver() mechanism.");
|
||||
}
|
||||
|
||||
1;
|
||||
177
Message/Transport/Email.pm
Normal file
177
Message/Transport/Email.pm
Normal file
@ -0,0 +1,177 @@
|
||||
## @file
|
||||
# This file contains the implementation of the EMail Message Transport class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program is free software: you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation, either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class Message::Transport::Email
|
||||
# This class implements the email transport system; lasciate ogne speranza, voi ch'intrate.
|
||||
#
|
||||
package Message::Transport::Email;
|
||||
use strict;
|
||||
use base qw(Message);
|
||||
use Encode;
|
||||
use Email::MIME;
|
||||
use Email::Sender::Simple qw(sendmail);
|
||||
use Email::Sender::Transport::SMTP;
|
||||
use Email::Sender::Transport::SMTP::Persistent;
|
||||
use Try::Tiny;
|
||||
|
||||
# ============================================================================
|
||||
# Constructor
|
||||
|
||||
## @cmethod Message::Transport::Email new(%args)
|
||||
# Create a new Message::Transport::Email object. This will create an object
|
||||
# that may be used to send messages to recipients over SMTP.
|
||||
#
|
||||
# @param args A hash of arguments to initialise the Message::Transport::Email
|
||||
# object with.
|
||||
# @return A new Message::Transport::Email object.
|
||||
sub new {
|
||||
my $invocant = shift;
|
||||
my $class = ref($invocant) || $invocant;
|
||||
my $self = $class -> SUPER::new(@_)
|
||||
or return undef;
|
||||
|
||||
# Make local copies of the config for readability
|
||||
# Arguments for Email::Sender::Transport::SMTP(::Persistent)
|
||||
$self -> {"host"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::smtp_host"};
|
||||
$self -> {"port"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::smtp_port"};
|
||||
$self -> {"ssl"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::smtp_secure"};
|
||||
$self -> {"username"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::username"};
|
||||
$self -> {"password"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::password"};
|
||||
|
||||
# Should persistent SMTP be used?
|
||||
$self -> {"persist"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::persist"};
|
||||
|
||||
# Should the sender be forced (ie: always use the system-specified sender, even if the message has
|
||||
# an explicit sender. This should be the address to set as the sender.
|
||||
$self -> {"force_sender"} = $self -> {"settings"} -> {"config"} -> {"Message::Transport::Email::force_sender"};
|
||||
|
||||
# The address to use as the envelope sender.
|
||||
$self -> {"env_sender"} = $self -> {"settings"} -> {"config"} -> {"Core:envelope_address"};
|
||||
|
||||
# set up persistent STMP if needed
|
||||
if($self -> {"persist"}) {
|
||||
eval { $self -> {"smtp"} = Email::Sender::Transport::SMTP::Persistent -> new(host => $self -> {"host"},
|
||||
port => $self -> {"port"},
|
||||
ssl => $self -> {"ssl"},
|
||||
sasl_username => $self -> {"username"},
|
||||
sasl_password => $self -> {"password"});
|
||||
};
|
||||
return SystemModule::set_error("SMTP Initialisation failed: $@") if($@);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
## @method void DESTROY()
|
||||
# Destructor method to clean up persistent SMTP if it is in use.
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
|
||||
$self -> {"smtp"} -> disconnect()
|
||||
if($self -> {"persist"} && $self -> {"smtp"});
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Delivery
|
||||
|
||||
## @method $ deliver($message)
|
||||
# Attempt to deliver the specified message to its recipients.
|
||||
#
|
||||
# @param message A reference to hash containing the message data.
|
||||
# @return True on success, undef on failure/error.
|
||||
sub deliver {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
|
||||
if(!$self -> {"persist"}) {
|
||||
eval { $self -> {"smtp"} = Email::Sender::Transport::SMTP -> new(host => $self -> {"host"},
|
||||
port => $self -> {"port"},
|
||||
ssl => $self -> {"ssl"},
|
||||
sasl_username => $self -> {"username"},
|
||||
sasl_password => $self -> {"password"});
|
||||
};
|
||||
return $self -> self_error("SMTP Initialisation failed: $@") if($@);
|
||||
}
|
||||
|
||||
my ($from, $to) = ($self -> {"env_sender"}, "");
|
||||
|
||||
# Work out the the sender if needed...
|
||||
if(!$self -> {"force_sender"} && $message -> {"sender"}) {
|
||||
$from = $self -> _get_user_email($message -> {"sender"} -> {"sender_id"})
|
||||
or return undef;
|
||||
}
|
||||
|
||||
# And the recipients
|
||||
foreach my $recipient (@{$message -> {"recipients"}}) {
|
||||
my $recip = $self -> _get_user_email($recipient -> {"recipient_id"})
|
||||
or return undef;
|
||||
|
||||
$to .= "," if($to);
|
||||
$to .= $recip;
|
||||
}
|
||||
|
||||
my $email = Email::MIME -> create(header_str => [ From => $from,
|
||||
To => $to,
|
||||
Subject => $message -> {"subject"}
|
||||
],
|
||||
body_str => Encode::encode_utf8($message -> {"body"}),
|
||||
attributes => { charset => 'utf8',
|
||||
content_type => "text/plain",
|
||||
encoding => 'base64' });
|
||||
|
||||
try {
|
||||
sendmail($email, { from => $self -> {"env_sender"},
|
||||
transport => $self -> {"smtp"}});
|
||||
} catch {
|
||||
return $self -> self_error("Delivery of message ".$message -> {"id"}." failed: $_");
|
||||
};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
# ============================================================================
|
||||
# Support code
|
||||
|
||||
## @method private $ _get_user_email($userid)
|
||||
# Obtain the email address set for the specified user. This class may be called outside
|
||||
# the normal application environment, so it might not have access to the AppUser or Session
|
||||
# classes - but it still needs email addresses! This looks directly into the user table
|
||||
# to obtain the address.
|
||||
#
|
||||
# @param userid The ID of the user to fetch the email address for.
|
||||
# @return The user's email address on success, undef on error.
|
||||
sub _get_user_email {
|
||||
my $self = shift;
|
||||
my $userid = shift;
|
||||
|
||||
my $userh = $self -> {"dbh"} -> prepare("SELECT email
|
||||
FROM ".$self -> {"settings"} -> {"database"} -> {"users"}."
|
||||
WHERE user_id = ?");
|
||||
$userh -> execute($userid)
|
||||
or return $self -> self_error("Unable to perform user email lookup: ". $self -> {"dbh"} -> errstr);
|
||||
|
||||
my $user = $userh -> fetchrow_arrayref()
|
||||
or return $self -> self_error("User email lookup failed: user $userid does not exist");
|
||||
|
||||
return $user -> [0];
|
||||
}
|
||||
|
||||
1;
|
||||
44
Message/Transport/Local.pm
Normal file
44
Message/Transport/Local.pm
Normal file
@ -0,0 +1,44 @@
|
||||
## @file
|
||||
# This file contains the implementation of the Local Message Transport class.
|
||||
#
|
||||
# @author Chris Page <chris@starforge.co.uk>
|
||||
#
|
||||
# This program is free software: you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation, either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
## @class Message::Transport::Local
|
||||
# This class implements the local delivery transport. Local delivery actually involves
|
||||
# no work whatsoever - any messages that are queued for local deliver can always be
|
||||
# delivered.
|
||||
package Message::Transport::Local;
|
||||
use strict;
|
||||
use base qw(Message);
|
||||
|
||||
# ============================================================================
|
||||
# Delivery
|
||||
|
||||
## @method $ deliver($message)
|
||||
# Attempt to deliver the specified message to its recipients. This function
|
||||
# is always successful - it is impossible for local delivery to fail, as the
|
||||
# message is already there!
|
||||
#
|
||||
# @param message A reference to hash containing the message data.
|
||||
# @return Always returns true.
|
||||
sub deliver {
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
x
Reference in New Issue
Block a user