diff --git a/Message.pm b/Message.pm index b31b717..f50887a 100644 --- a/Message.pm +++ b/Message.pm @@ -126,4 +126,5 @@ sub load_transport_module { return $self -> {"module"} -> load_module($modname -> [0]); } + 1; diff --git a/Message/Queue.pm b/Message/Queue.pm index d2dcb75..73a6c68 100644 --- a/Message/Queue.pm +++ b/Message/Queue.pm @@ -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 diff --git a/Message/Transport.pm b/Message/Transport.pm new file mode 100644 index 0000000..b6101a3 --- /dev/null +++ b/Message/Transport.pm @@ -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 . + +## @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; diff --git a/Message/Transport/Email.pm b/Message/Transport/Email.pm new file mode 100644 index 0000000..a583b60 --- /dev/null +++ b/Message/Transport/Email.pm @@ -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 . + +## @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; diff --git a/Message/Transport/Local.pm b/Message/Transport/Local.pm new file mode 100644 index 0000000..6b68a71 --- /dev/null +++ b/Message/Transport/Local.pm @@ -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 . + +## @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;