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]);
|
return $self -> {"module"} -> load_module($modname -> [0]);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
1;
|
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
|
# 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