notice-sender/trunk/Nos.pm

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.5';

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;


=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
track replies.

It is best used to send smaller 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<perldoc sender.pl>).
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,
 );

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.

=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 new_list

Create new list. Required arguments are name of C<list> and
C<email> address.

 $nos->new_list(
        list => 'My list',
        from => 'Outgoing from comment',
        email => 'my-list@example.com',
 );

Returns ID of newly created list.

Calls internally C<_add_list>, see details there.

=cut

sub new_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 delete_list

Delete list from database.

 my $ok = delete_list(
        list => 'My list'
 );

Returns false if list doesn't exist.

=cut

sub delete_list {
        my $self = shift;

        my $args = {@_};

        croak "need list to delete" unless ($args->{'list'});

        $args->{'list'} = lc($args->{'list'});

        my $lists = $self->{'loader'}->find_class('lists');

        my $this_list = $lists->search( name => $args->{'list'} )->first || return;

        $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 informations 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";

        unless( $m->header('Subject') ) {
                warn "message doesn't have Subject header\n";
                return;
        }

        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,
 );

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

=back

Default sleep wait between two messages is 3 seconds.

=cut

sub send_queued_messages {
        my $self = shift;

        my $arg = {@_};

        my $list_name = lc($arg->{'list'}) || '';
        my $driver = $arg->{'driver'} || '';
        my $sleep = $arg->{'sleep'};
        $sleep ||= 3 unless defined($sleep);

        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'];
        } else {
                warn "dumping all messages to STDERR\n";
        }

        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";
                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";
                        } else {
                                print "=> $to_email\n";

                                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
                                if (@email_send_options) {
                                        send $email_send_driver => $m_obj->as_string, @email_send_options;
                                } else {
                                        send $email_send_driver => $m_obj->as_string;
                                }

                                $sent->create({
                                        message_id => $m->message_id,
                                        user_id => $u->user_id,
                                        hash => $hash,
                                });
                                $sent->dbi_commit;

                                if ($sleep) {
                                        warn "sleeping $sleep seconds\n";
                                        sleep($sleep);
                                }
                        }
                }
                $m->all_sent(1);
                $m->update;
                $m->dbi_commit;
        }

}

=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";
}


=head1 INTERNAL METHODS

Beware of dragons! You shouldn't need to call those methods directly.

=head2 _add_list

Create new list

 my $list_obj = $nos->_add_list(
        list => 'My list',
        from => 'Outgoing from comment',
        email => 'my-list@example.com',
 );

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 $from_addr = $arg->{'from'};

        my $lists = $self->{'loader'}->find_class('lists');

        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;
}

###
### 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;

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        $nos = new Nos( @_ ) || die "can't create Nos object";

        $self ? return $self : return undef;
}


=head2 NewList

 $message_id = NewList(
        list => 'My list',
        from => 'Name of my list',
        email => 'my-list@example.com'
 ); 

=cut

sub NewList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->new_list(
                        list => $_[0], from => $_[1], email => $_[2],
                );
        } else {
                return $nos->new_list( %{ shift @_ } );
        }
}


=head2 DeleteList

 $ok = DeleteList(
        list => 'My list',
 ); 

=cut

sub DeleteList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->delete_list(
                        list => $_[0],
                );
        } else {
                return $nos->delete_list( %{ shift @_ } );
        }
}

=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 => $_[4],
                );
        } 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>.

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.

=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 @_ } );
        }
}


###

=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;