package Nos;
use 5.008;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.9';
use Class::DBI::Loader;
use Email::Valid;
use Email::Send;
use Carp;
use Email::Auth::AddressHash;
use Email::Simple;
use Email::Address;
use Mail::DeliveryStatus::BounceParser;
use Class::DBI::AbstractSearch;
use SQL::Abstract;
use Mail::Alias;
use Cwd qw(abs_path);
=head1 NAME
Nos - Notice Sender core module
=head1 SYNOPSIS
use Nos;
my $nos = new Nos();
=head1 DESCRIPTION
Notice sender is mail handler. It is not MTA, since it doesn't know how to
receive e-mails or send them directly to other hosts. It is not mail list
manager because it requires programming to add list members and send
messages. You can think of it as mechanisam for off-loading your e-mail
sending to remote server using SOAP service.
It's concept is based around B<lists>. Each list can have zero or more
B<members>. Each list can have zero or more B<messages>.
Here comes a twist: each outgoing message will have unique e-mail generated,
so Notice Sender will be able to link received replies (or bounces) with
outgoing messages.
It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
send attachments, handle 8-bit characters in headers (which have to be
encoded) or anything else.
It will just queue your e-mail message to particular list (sending it to
possibly remote Notice Sender SOAP server just once), send it out at
reasonable rate (so that it doesn't flood your e-mail infrastructure) and
keep track replies.
It is best used to send small number of messages to more-or-less fixed
list of recipients while allowing individual responses to be examined.
Tipical use include replacing php e-mail sending code with SOAP call to
Notice Sender. It does support additional C<ext_id> field for each member
which can be used to track some unique identifier from remote system for
particular user.
It comes with command-line utility C<sender.pl> which can be used to perform
all available operation from scripts (see C<sender.pl --man>).
This command is also useful for debugging while writing client SOAP
application.
=head1 METHODS
=head2 new
Create new instance specifing database, user, password and options.
my $nos = new Nos(
dsn => 'dbi:Pg:dbname=notices',
user => 'dpavlin',
passwd => '',
debug => 1,
verbose => 1,
hash_len => 8,
full_hostname_in_aliases => 0,
);
Parametar C<hash_len> defines length of hash which will be added to each
outgoing e-mail message to ensure that replies can be linked with sent e-mails.
C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
postalias) to include full hostname in aliases file.
=cut
sub new {
my $class = shift;
my $self = {@_};
bless($self, $class);
croak "need at least dsn" unless ($self->{'dsn'});
$self->{'loader'} = Class::DBI::Loader->new(
debug => $self->{'debug'},
dsn => $self->{'dsn'},
user => $self->{'user'},
password => $self->{'passwd'},
namespace => "Nos",
additional_classes => qw/Class::DBI::AbstractSearch/,
# additional_base_classes => qw/My::Stuff/,
relationships => 1,
) || croak "can't init Class::DBI::Loader";
$self->{'hash_len'} ||= 8;
$self ? return $self : return undef;
}
=head2 create_list
Create new list. Required arguments are name of C<list>, C<email> address
and path to C<aliases> file.
$nos->create_list(
list => 'My list',
from => 'Outgoing from comment',
email => 'my-list@example.com',
aliases => '/etc/mail/mylist',
archive => '/path/to/mbox/archive',
);
Returns ID of newly created list.
Calls internally C<_add_list>, see details there.
=cut
sub create_list {
my $self = shift;
my $arg = {@_};
confess "need list name" unless ($arg->{'list'});
confess "need list email" unless ($arg->{'email'});
$arg->{'list'} = lc($arg->{'list'});
$arg->{'email'} = lc($arg->{'email'});
my $l = $self->_get_list($arg->{'list'}) ||
$self->_add_list( @_ ) ||
return undef;
return $l->id;
}
=head2 drop_list
Delete list from database.
my $ok = drop_list(
list => 'My list'
aliases => '/etc/mail/mylist',
);
Returns false if list doesn't exist.
=cut
sub drop_list {
my $self = shift;
my $args = {@_};
croak "need list to delete" unless ($args->{'list'});
$args->{'list'} = lc($args->{'list'});
my $aliases = $args->{'aliases'} || croak "need path to aliases file";
my $lists = $self->{'loader'}->find_class('lists');
my $this_list = $lists->search( name => $args->{'list'} )->first || return;
$self->_remove_alias( email => $this_list->email, aliases => $aliases);
$this_list->delete || croak "can't delete list\n";
return $lists->dbi_commit || croak "can't commit";
}
=head2 add_member_to_list
Add new member to list
$nos->add_member_to_list(
list => "My list",
email => "john.doe@example.com",
name => "John A. Doe",
ext_id => 42,
);
C<name> and C<ext_id> parametars are optional.
Return member ID if user is added.
=cut
sub add_member_to_list {
my $self = shift;
my $arg = {@_};
my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
my $name = $arg->{'name'} || '';
my $list_name = lc($arg->{'list'}) || croak "need list name";
my $ext_id = $arg->{'ext_id'};
my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
if (! Email::Valid->address($email)) {
carp "SKIPPING $name <$email>\n";
return 0;
}
carp "# $name <$email>\n" if ($self->{'verbose'});
my $users = $self->{'loader'}->find_class('users');
my $user_list = $self->{'loader'}->find_class('user_list');
my $this_user = $users->find_or_create({
email => $email,
}) || croak "can't find or create member\n";
if ($name && $this_user->name ne $name) {
$this_user->name($name || '');
$this_user->update;
}
if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
$this_user->ext_id($ext_id);
$this_user->update;
}
my $user_on_list = $user_list->find_or_create({
user_id => $this_user->id,
list_id => $list->id,
}) || croak "can't add user to list";
$list->dbi_commit;
$this_user->dbi_commit;
$user_on_list->dbi_commit;
return $this_user->id;
}
=head2 list_members
List all members of some list.
my @members = list_members(
list => 'My list',
);
Returns array of hashes with user information like this:
$member = {
name => 'Dobrica Pavlinusic',
email => 'dpavlin@rot13.org
}
If list is not found, returns false. If there is C<ext_id> in user data,
it will also be returned.
=cut
sub list_members {
my $self = shift;
my $args = {@_};
my $list_name = lc($args->{'list'}) || confess "need list name";
my $lists = $self->{'loader'}->find_class('lists');
my $user_list = $self->{'loader'}->find_class('user_list');
my $this_list = $lists->search( name => $list_name )->first || return;
my @results;
foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
my $row = {
name => $user_on_list->user_id->name,
email => $user_on_list->user_id->email,
};
my $ext_id = $user_on_list->user_id->ext_id;
$row->{'ext_id'} = $ext_id if (defined($ext_id));
push @results, $row;
}
return @results;
}
=head2 delete_member
Delete member from database.
my $ok = delete_member(
name => 'Dobrica Pavlinusic'
);
my $ok = delete_member(
email => 'dpavlin@rot13.org'
);
Returns false if user doesn't exist.
This function will delete member from all lists (by cascading delete), so it
shouldn't be used lightly.
=cut
sub delete_member {
my $self = shift;
my $args = {@_};
croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
$args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
my $key = 'name';
$key = 'email' if ($args->{'email'});
my $users = $self->{'loader'}->find_class('users');
my $this_user = $users->search( $key => $args->{$key} )->first || return;
$this_user->delete || croak "can't delete user\n";
return $users->dbi_commit || croak "can't commit";
}
=head2 delete_member_from_list
Delete member from particular list.
my $ok = delete_member_from_list(
list => 'My list',
email => 'dpavlin@rot13.org',
);
Returns false if user doesn't exist on that particular list.
It will die if list or user doesn't exist. You have been warned (you might
want to eval this functon to prevent it from croaking).
=cut
sub delete_member_from_list {
my $self = shift;
my $args = {@_};
croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
$args->{'list'} = lc($args->{'list'});
$args->{'email'} = lc($args->{'email'});
my $user = $self->{'loader'}->find_class('users');
my $list = $self->{'loader'}->find_class('lists');
my $user_list = $self->{'loader'}->find_class('user_list');
my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
$this_user_list->delete || croak "can't delete user from list\n";
return $user_list->dbi_commit || croak "can't commit";
}
=head2 add_message_to_list
Adds message to one list's queue for later sending.
$nos->add_message_to_list(
list => 'My list',
message => 'Subject: welcome to list
This is example message
',
);
On success returns ID of newly created (or existing) message.
Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
will be automatically generated, but if you want to use own headers, just
include them in messages.
=cut
sub add_message_to_list {
my $self = shift;
my $args = {@_};
my $list_name = lc($args->{'list'}) || confess "need list name";
my $message_text = $args->{'message'} || croak "need message";
my $m = Email::Simple->new($message_text) || croak "can't parse message";
warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
my $lists = $self->{'loader'}->find_class('lists');
my $this_list = $lists->search(
name => $list_name,
)->first || croak "can't find list $list_name";
my $messages = $self->{'loader'}->find_class('messages');
my $this_message = $messages->find_or_create({
message => $message_text
}) || croak "can't insert message";
$this_message->dbi_commit() || croak "can't add message";
my $queue = $self->{'loader'}->find_class('queue');
$queue->find_or_create({
message_id => $this_message->id,
list_id => $this_list->id,
}) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
$queue->dbi_commit || croak "can't add message to list ",$this_list->name;
return $this_message->id;
}
=head2 send_queued_messages
Send queued messages or just ones for selected list
$nos->send_queued_messages(
list => 'My list',
driver => 'smtp',
sleep => 3,
verbose => 1,
);
Second option is driver which will be used for e-mail delivery. If not
specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
Other valid drivers are:
=over 10
=item smtp
Send e-mail using SMTP server at 127.0.0.1
=item verbose
Display diagnostic output to C<STDOUT> and C<STDERR>.
=back
Any other driver name will try to use C<Email::Send::that_driver> module.
Default sleep wait between two messages is 3 seconds.
This method will return number of succesfully sent messages.
=cut
sub send_queued_messages {
my $self = shift;
my $arg = {@_};
my $list_name = lc($arg->{'list'}) || '';
my $driver = $arg->{'driver'} || '';
my $sleep = $arg->{'sleep'};
my $verbose = $arg->{verbose};
$sleep ||= 3 unless defined($sleep);
# number of messages sent o.k.
my $ok = 0;
my $email_send_driver = 'Email::Send::IO';
my @email_send_options;
if (lc($driver) eq 'smtp') {
$email_send_driver = 'Email::Send::SMTP';
@email_send_options = ['127.0.0.1'];
} elsif ($driver && $driver ne '') {
$email_send_driver = 'Email::Send::' . $driver;
} else {
warn "dumping all messages to STDERR\n" if ($verbose);
}
my $lists = $self->{'loader'}->find_class('lists');
my $queue = $self->{'loader'}->find_class('queue');
my $user_list = $self->{'loader'}->find_class('user_list');
my $sent = $self->{'loader'}->find_class('sent');
my $my_q;
if ($list_name ne '') {
my $l_id = $lists->search_like( name => $list_name )->first ||
croak "can't find list $list_name";
$my_q = $queue->search_like( list_id => $l_id ) ||
croak "can't find list $list_name";
} else {
$my_q = $queue->retrieve_all;
}
while (my $m = $my_q->next) {
next if ($m->all_sent);
print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
my $msg = $m->message_id->message;
foreach my $u ($user_list->search(list_id => $m->list_id)) {
my $to_email = $u->user_id->email;
my ($from,$domain) = split(/@/, $u->list_id->email, 2);
if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
print "SKIP $to_email message allready sent\n" if ($verbose);
} else {
print "=> $to_email " if ($verbose);
my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
my $hash = $auth->generate_hash( $to_email );
my $from_addr;
my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
$from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
$from_addr .= '<' . $from_email_only . '>';
my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
$m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
#$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
$m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
$m_obj->header_set('From', $from_addr) || croak "can't set From: header";
$m_obj->header_set('To', $to) || croak "can't set To: header";
$m_obj->header_set('X-Nos-Version', $VERSION);
$m_obj->header_set('X-Nos-Hash', $hash);
# really send e-mail
my $sent_status;
if (@email_send_options) {
$sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
} else {
$sent_status = send $email_send_driver => $m_obj->as_string;
}
croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
my @bad;
@bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
croak "failed sending to ",join(",",@bad) if (@bad);
if ($sent_status) {
$sent->create({
message_id => $m->message_id,
user_id => $u->user_id,
hash => $hash,
});
$sent->dbi_commit;
print " - $sent_status\n" if ($verbose);
$ok++;
} else {
warn "ERROR: $sent_status\n" if ($verbose);
}
if ($sleep) {
warn "sleeping $sleep seconds\n" if ($verbose);
sleep($sleep);
}
}
}
$m->all_sent(1);
$m->update;
$m->dbi_commit;
}
return $ok;
}
=head2 inbox_message
Receive single message for list's inbox.
my $ok = $nos->inbox_message(
list => 'My list',
message => $message,
);
This method is used by C<sender.pl> when receiving e-mail messages.
=cut
sub inbox_message {
my $self = shift;
my $arg = {@_};
return unless ($arg->{'message'});
croak "need list name" unless ($arg->{'list'});
$arg->{'list'} = lc($arg->{'list'});
my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
my $to = $m->header('To') || die "can't find To: address in incomming message\n";
my $return_path = $m->header('Return-Path') || '';
my @addrs = Email::Address->parse( $to );
die "can't parse To: $to address\n" unless (@addrs);
my $hl = $self->{'hash_len'} || confess "no hash_len?";
my $hash;
foreach my $a (@addrs) {
if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
$hash = $1;
last;
}
}
#warn "can't find hash in e-mail $to\n" unless ($hash);
my $sent = $self->{'loader'}->find_class('sent');
# will use null if no matching message_id is found
my $sent_msg;
$sent_msg = $sent->search( hash => $hash )->first if ($hash);
my ($message_id, $user_id) = (undef, undef); # init with NULL
if ($sent_msg) {
$message_id = $sent_msg->message_id || carp "no message_id";
$user_id = $sent_msg->user_id || carp "no user_id";
} else {
#warn "can't find sender with hash $hash\n";
my $users = $self->{'loader'}->find_class('users');
my $from = $m->header('From');
$from = $1 if ($from =~ m/<(.*)>/);
my $this_user = $users->search( email => lc($from) )->first;
$user_id = $this_user->id if ($this_user);
}
my $is_bounce = 0;
if ($return_path eq '<>' || $return_path eq '') {
no warnings;
my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
$arg->{'message'}, { report_non_bounces=>1 },
) };
#warn "can't check if this message is bounce!" if ($@);
$is_bounce++ if ($bounce && $bounce->is_bounce);
}
my $received = $self->{'loader'}->find_class('received');
my $this_received = $received->find_or_create({
user_id => $user_id,
list_id => $this_list->id,
message_id => $message_id,
message => $arg->{'message'},
bounced => $is_bounce,
}) || croak "can't insert received message";
$this_received->dbi_commit;
# print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
}
=head2 received_messages
Returns all received messages for given list or user.
my @received = $nos->received_messages(
list => 'My list',
email => "john.doe@example.com",
from_date => '2005-01-01 10:15:00',
to_date => '2005-01-01 12:00:00',
message => 0,
);
If don't specify C<list> or C<email> it will return all received messages.
Results will be sorted by received date, oldest first.
Other optional parametars include:
=over 10
=item from_date
Date (in ISO format) for lower limit of dates received
=item to_date
Return just messages older than this date
=item message
Include whole received message in result. This will probably make result
array very large. Use with care.
=back
Date ranges are inclusive, so results will include messages sent on
particular date specified with C<date_from> or C<date_to>.
Each element in returned array will have following structure:
my $row = {
id => 42, # unique ID of received message
list => 'My list', # useful if filtering by email
ext_id => 9999, # ext_id from message sender
email => 'jdoe@example.com', # e-mail of message sender
bounced => 0, # true if message is bounce
date => '2005-08-24 18:57:24', # date of receival in ISO format
}
If you specified C<message> option, this hash will also have C<message> key
which will contain whole received message.
=cut
sub received_messages {
my $self = shift;
my $arg = {@_} if (@_);
# croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
my $sql = qq{
select
received.id as id,
lists.name as list,
users.ext_id as ext_id,
users.email as email,
};
$sql .= qq{ message,} if ($arg->{'message'});
$sql .= qq{
bounced,received.date as date
from received
join lists on lists.id = list_id
join users on users.id = user_id
};
my $order = qq{ order by date asc };
my $where;
$where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
$where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
$where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
$where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
# hum, yammy one-liner
my($stmt, @bind) = SQL::Abstract->new->where($where);
my $dbh = $self->{'loader'}->find_class('received')->db_Main;
my $sth = $dbh->prepare($sql . $stmt . $order);
$sth->execute(@bind);
return $sth->fetchall_hash;
}
=head1 INTERNAL METHODS
Beware of dragons! You shouldn't need to call those methods directly.
=head2 _add_aliases
Add or update alias in C</etc/aliases> (or equivalent) file for selected list
my $ok = $nos->add_aliases(
list => 'My list',
email => 'my-list@example.com',
aliases => '/etc/mail/mylist',
archive => '/path/to/mbox/archive',
);
C<archive> parametar is optional.
Return false on failure.
=cut
sub _add_aliases {
my $self = shift;
my $arg = {@_};
foreach my $o (qw/list email aliases/) {
croak "need $o option" unless ($arg->{$o});
}
my $aliases = $arg->{'aliases'};
my $email = $arg->{'email'};
my $list = $arg->{'list'};
unless (-e $aliases) {
warn "aliases file $aliases doesn't exist, creating empty\n";
open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
close($fh);
chmod 0777, $aliases || warn "can't change permission to 0777";
}
die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
my $target = '';
if (my $archive = $arg->{'archive'}) {
$target .= "$archive, ";
if (! -e $archive) {
warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
close($fh);
chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
}
}
# resolve my path to absolute one
my $self_path = abs_path($0);
$self_path =~ s#/[^/]+$##;
$self_path =~ s#/t/*$#/#;
$target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
# remove hostname from email to make Postfix's postalias happy
$email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
if ($a->exists($email)) {
$a->update($email, $target) or croak "can't update alias ".$a->error_check;
} else {
$a->append($email, $target) or croak "can't add alias ".$a->error_check;
}
# $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
return 1;
}
=head2 _add_list
Create new list
my $list_obj = $nos->_add_list(
list => 'My list',
from => 'Outgoing from comment',
email => 'my-list@example.com',
aliases => '/etc/mail/mylist',
);
Returns C<Class::DBI> object for created list.
C<email> address can be with domain or without it if your
MTA appends it. There is no checking for validity of your
list e-mail. Flexibility comes with resposibility, so please
feed correct (and configured) return addresses.
=cut
sub _add_list {
my $self = shift;
my $arg = {@_};
my $name = lc($arg->{'list'}) || confess "can't add list without name";
my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
my $from_addr = $arg->{'from'};
my $lists = $self->{'loader'}->find_class('lists');
$self->_add_aliases(
list => $name,
email => $email,
aliases => $aliases,
) || warn "can't add alias $email for list $name";
my $l = $lists->find_or_create({
name => $name,
email => $email,
});
croak "can't add list $name\n" unless ($l);
if ($from_addr && $l->from_addr ne $from_addr) {
$l->from_addr($from_addr);
$l->update;
}
$l->dbi_commit;
return $l;
}
=head2 _get_list
Get list C<Class::DBI> object.
my $list_obj = $nos->check_list('My list');
Returns false on failure.
=cut
sub _get_list {
my $self = shift;
my $name = shift || return;
my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
return $lists->search({ name => lc($name) })->first;
}
=head2 _remove_alias
Remove list alias
my $ok = $nos->_remove_alias(
email => 'mylist@example.com',
aliases => '/etc/mail/mylist',
);
Returns true if list is removed or false if list doesn't exist. Dies in case of error.
=cut
sub _remove_alias {
my $self = shift;
my $arg = {@_};
my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
if ($a->exists($email)) {
$a->delete($email) || croak "can't remove alias $email";
} else {
return 0;
}
return 1;
}
###
### SOAP
###
package Nos::SOAP;
use Carp;
=head1 SOAP methods
This methods are thin wrappers to provide SOAP calls. They are grouped in
C<Nos::SOAP> package which is in same F<Nos.pm> module file.
Usually, you want to use named variables in your SOAP calls if at all
possible.
However, if you have broken SOAP library (like PHP SOAP class from PEAR)
you will want to use positional arguments (in same order as documented for
methods below).
=cut
my $nos;
=head2 new
Create new SOAP object
my $soap = new Nos::SOAP(
dsn => 'dbi:Pg:dbname=notices',
user => 'dpavlin',
passwd => '',
debug => 1,
verbose => 1,
hash_len => 8,
aliases => '/etc/aliases',
);
If you are writing SOAP server (like C<soap.cgi> example), you will need to
call this method once to make new instance of Nos::SOAP and specify C<dsn>
and options for it.
=cut
sub new {
my $class = shift;
my $self = {@_};
croak "need aliases parametar" unless ($self->{'aliases'});
bless($self, $class);
$nos = new Nos( @_ ) || die "can't create Nos object";
$self ? return $self : return undef;
}
=head2 CreateList
$message_id = CreateList(
list => 'My list',
from => 'Name of my list',
email => 'my-list@example.com'
);
=cut
sub CreateList {
my $self = shift;
my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
if ($_[0] !~ m/^HASH/) {
return $nos->create_list(
list => $_[0], from => $_[1], email => $_[2],
aliases => $aliases,
);
} else {
return $nos->create_list( %{ shift @_ }, aliases => $aliases );
}
}
=head2 DropList
$ok = DropList(
list => 'My list',
);
=cut
sub DropList {
my $self = shift;
my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
if ($_[0] !~ m/^HASH/) {
return $nos->drop_list(
list => $_[0],
aliases => $aliases,
);
} else {
return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
}
}
=head2 AddMemberToList
$member_id = AddMemberToList(
list => 'My list',
email => 'e-mail@example.com',
name => 'Full Name',
ext_id => 42,
);
=cut
sub AddMemberToList {
my $self = shift;
if ($_[0] !~ m/^HASH/) {
return $nos->add_member_to_list(
list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
);
} else {
return $nos->add_member_to_list( %{ shift @_ } );
}
}
=head2 ListMembers
my @members = ListMembers(
list => 'My list',
);
Returns array of hashes with user informations, see C<list_members>.
=cut
sub ListMembers {
my $self = shift;
my $list_name;
if ($_[0] !~ m/^HASH/) {
$list_name = shift;
} else {
$list_name = $_[0]->{'list'};
}
return [ $nos->list_members( list => $list_name ) ];
}
=head2 DeleteMemberFromList
$member_id = DeleteMemberFromList(
list => 'My list',
email => 'e-mail@example.com',
);
=cut
sub DeleteMemberFromList {
my $self = shift;
if ($_[0] !~ m/^HASH/) {
return $nos->delete_member_from_list(
list => $_[0], email => $_[1],
);
} else {
return $nos->delete_member_from_list( %{ shift @_ } );
}
}
=head2 AddMessageToList
$message_id = AddMessageToList(
list => 'My list',
message => 'From: My list...'
);
=cut
sub AddMessageToList {
my $self = shift;
if ($_[0] !~ m/^HASH/) {
return $nos->add_message_to_list(
list => $_[0], message => $_[1],
);
} else {
return $nos->add_message_to_list( %{ shift @_ } );
}
}
=head2 MessagesReceived
Return statistics about received messages.
my @result = MessagesReceived(
list => 'My list',
email => 'jdoe@example.com',
from_date => '2005-01-01 10:15:00',
to_date => '2005-01-01 12:00:00',
message => 0,
);
You must specify C<list> or C<email> or any combination of those two. Other
parametars are optional.
For format of returned array element see C<received_messages>.
=cut
sub MessagesReceived {
my $self = shift;
if ($_[0] !~ m/^HASH/) {
die "need at least list or email" unless (scalar @_ < 2);
return \@{ $nos->received_messages(
list => $_[0], email => $_[1],
from_date => $_[2], to_date => $_[3],
message => $_[4]
) };
} else {
my $arg = shift;
die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
return \@{ $nos->received_messages( %{ $arg } ) };
}
}
=head2 SendTest
Internal function which does e-mail sending using C<Email::Send::Test> driver.
my $sent = SendTest( list => 'My list' );
Returns number of messages sent
=cut
sub SendTest {
my $self = shift;
my $args = shift;
die "list name required" unless ($args->{list});
require Email::Send::Test;
my $nr_sent = $nos->send_queued_messages(
list => $args->{list},
driver => 'Test',
sleep => 0,
verbose => 0,
);
my @emails = Email::Send::Test->emails;
open(my $tmp, ">/tmp/soap-debug");
use Data::Dump qw/dump/;
print $tmp "sent $nr_sent emails\n", dump(@emails);
close($tmp);
return $nr_sent;
}
###
=head1 NOTE ON ARRAYS IN SOAP
Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
seems that SOAP::Lite client thinks that it has array with one element which
is array of hashes with data.
=head1 EXPORT
Nothing.
=head1 SEE ALSO
mailman, ezmlm, sympa, L<Mail::Salsa>
=head1 AUTHOR
Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005 by Dobrica Pavlinusic
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.
=cut
1;
RSS Feed