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

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;


=head1 NAME

Nos - Notice Sender core module

=head1 SYNOPSIS

  use Nos;
  my $nos = new Nos();

=head1 DESCRIPTION

Core module for notice sender's functionality.

=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 L<_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 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",
 );

C<name> parametar is 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 $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;
        }

        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.

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

                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.

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

=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',
        email => 'my-list@example.com'
 ); 

=cut

sub NewList {
        my $self = shift;

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


=head2 AddMemberToList

 $member_id = AddMemberToList(
        list => 'My list',
        email => 'e-mail@example.com',
        name => 'Full Name'
 );

=cut

sub AddMemberToList {
        my $self = shift;

        if ($_[0] !~ m/^HASH/) {
                return $nos->add_member_to_list(
                        list => $_[0], email => $_[1], name => $_[2],
                );
        } 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 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;
1	dpavlin	20	package Nos;
2
3			use 5.008;
4			use strict;
5			use warnings;
6
7			require Exporter;
8
9			our @ISA = qw(Exporter);
10
11			our %EXPORT_TAGS = ( 'all' => [ qw(
12			) ] );
13
14			our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
15
16			our @EXPORT = qw(
17			);
18
19	dpavlin	45	our $VERSION = '0.4';
20	dpavlin	20
21			use Class::DBI::Loader;
22			use Email::Valid;
23			use Email::Send;
24			use Carp;
25	dpavlin	29	use Email::Auth::AddressHash;
26			use Email::Simple;
27	dpavlin	36	use Email::Address;
28	dpavlin	37	use Mail::DeliveryStatus::BounceParser;
29	dpavlin	20
30	dpavlin	47
31	dpavlin	20	=head1 NAME
32
33			Nos - Notice Sender core module
34
35			=head1 SYNOPSIS
36
37			use Nos;
38			my $nos = new Nos();
39
40			=head1 DESCRIPTION
41
42			Core module for notice sender's functionality.
43
44			=head1 METHODS
45
46			=head2 new
47
48			Create new instance specifing database, user, password and options.
49
50			my $nos = new Nos(
51			dsn => 'dbi:Pg:dbname=notices',
52			user => 'dpavlin',
53			passwd => '',
54			debug => 1,
55			verbose => 1,
56	dpavlin	36	hash_len => 8,
57	dpavlin	20	);
58
59	dpavlin	38	Parametar C<hash_len> defines length of hash which will be added to each
60			outgoing e-mail message to ensure that replies can be linked with sent e-mails.
61	dpavlin	36
62	dpavlin	20	=cut
63
64			sub new {
65			my $class = shift;
66			my $self = {@_};
67			bless($self, $class);
68
69	dpavlin	22	croak "need at least dsn" unless ($self->{'dsn'});
70
71	dpavlin	20	$self->{'loader'} = Class::DBI::Loader->new(
72			debug => $self->{'debug'},
73			dsn => $self->{'dsn'},
74			user => $self->{'user'},
75			password => $self->{'passwd'},
76			namespace => "Nos",
77			# additional_classes => qw/Class::DBI::AbstractSearch/,
78			# additional_base_classes => qw/My::Stuff/,
79			relationships => 1,
80	dpavlin	22	) \|\| croak "can't init Class::DBI::Loader";
81	dpavlin	20
82	dpavlin	36	$self->{'hash_len'} \|\|= 8;
83
84	dpavlin	20	$self ? return $self : return undef;
85			}
86
87	dpavlin	30
88	dpavlin	33	=head2 new_list
89
90	dpavlin	38	Create new list. Required arguments are name of C<list> and
91			C<email> address.
92	dpavlin	33
93			$nos->new_list(
94	dpavlin	38	list => 'My list',
95	dpavlin	47	from => 'Outgoing from comment',
96	dpavlin	33	email => 'my-list@example.com',
97			);
98
99			Returns ID of newly created list.
100
101	dpavlin	38	Calls internally L<_add_list>, see details there.
102
103	dpavlin	33	=cut
104
105			sub new_list {
106			my $self = shift;
107
108			my $arg = {@_};
109
110			confess "need list name" unless ($arg->{'list'});
111	dpavlin	52	confess "need list email" unless ($arg->{'email'});
112	dpavlin	33
113	dpavlin	52	$arg->{'list'} = lc($arg->{'list'});
114			$arg->{'email'} = lc($arg->{'email'});
115
116	dpavlin	33	my $l = $self->_get_list($arg->{'list'}) \|\|
117			$self->_add_list( @_ ) \|\|
118			return undef;
119
120			return $l->id;
121			}
122
123
124	dpavlin	23	=head2 add_member_to_list
125
126			Add new member to list
127
128			$nos->add_member_to_list(
129			list => "My list",
130			email => "john.doe@example.com",
131			name => "John A. Doe",
132			);
133
134			C<name> parametar is optional.
135
136	dpavlin	27	Return member ID if user is added.
137	dpavlin	23
138			=cut
139
140			sub add_member_to_list {
141			my $self = shift;
142
143			my $arg = {@_};
144
145	dpavlin	52	my $email = lc($arg->{'email'}) \|\| croak "can't add user without e-mail";
146	dpavlin	23	my $name = $arg->{'name'} \|\| '';
147	dpavlin	52	my $list_name = lc($arg->{'list'}) \|\| croak "need list name";
148	dpavlin	23
149	dpavlin	30	my $list = $self->_get_list($list_name) \|\| croak "list $list_name doesn't exist";
150
151	dpavlin	23	if (! Email::Valid->address($email)) {
152	dpavlin	33	carp "SKIPPING $name <$email>\n";
153	dpavlin	23	return 0;
154			}
155
156	dpavlin	29	carp "# $name <$email>\n" if ($self->{'verbose'});
157	dpavlin	23
158			my $users = $self->{'loader'}->find_class('users');
159			my $user_list = $self->{'loader'}->find_class('user_list');
160
161			my $this_user = $users->find_or_create({
162			email => $email,
163			}) \|\| croak "can't find or create member\n";
164
165	dpavlin	45	if ($name && $this_user->name ne $name) {
166			$this_user->name($name \|\| '');
167	dpavlin	33	$this_user->update;
168			}
169
170	dpavlin	23	my $user_on_list = $user_list->find_or_create({
171			user_id => $this_user->id,
172			list_id => $list->id,
173			}) \|\| croak "can't add user to list";
174
175			$list->dbi_commit;
176			$this_user->dbi_commit;
177			$user_on_list->dbi_commit;
178
179	dpavlin	27	return $this_user->id;
180	dpavlin	23	}
181
182	dpavlin	43	=head2 list_members
183
184	dpavlin	45	List all members of some list.
185
186	dpavlin	43	my @members = list_members(
187			list => 'My list',
188			);
189
190			Returns array of hashes with user informations like this:
191
192			$member = {
193	dpavlin	45	name => 'Dobrica Pavlinusic',
194	dpavlin	43	email => 'dpavlin@rot13.org
195			}
196
197	dpavlin	45	If list is not found, returns false.
198
199	dpavlin	43	=cut
200
201			sub list_members {
202			my $self = shift;
203
204			my $args = {@_};
205
206	dpavlin	52	my $list_name = lc($args->{'list'}) \|\| confess "need list name";
207	dpavlin	43
208			my $lists = $self->{'loader'}->find_class('lists');
209			my $user_list = $self->{'loader'}->find_class('user_list');
210
211	dpavlin	45	my $this_list = $lists->search( name => $list_name )->first \|\| return;
212	dpavlin	43
213			my @results;
214
215			foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
216			my $row = {
217	dpavlin	45	name => $user_on_list->user_id->name,
218	dpavlin	43	email => $user_on_list->user_id->email,
219			};
220
221			push @results, $row;
222			}
223
224			return @results;
225
226			}
227
228
229	dpavlin	45	=head2 delete_member
230
231			Delete member from database.
232
233			my $ok = delete_member(
234			name => 'Dobrica Pavlinusic'
235			);
236
237			my $ok = delete_member(
238			email => 'dpavlin@rot13.org'
239			);
240
241			Returns false if user doesn't exist.
242
243			=cut
244
245			sub delete_member {
246			my $self = shift;
247
248			my $args = {@_};
249
250			croak "need name or email of user to delete" unless ($args->{'name'} \|\| $args->{'email'});
251
252	dpavlin	52	$args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
253
254	dpavlin	45	my $key = 'name';
255			$key = 'email' if ($args->{'email'});
256
257			my $users = $self->{'loader'}->find_class('users');
258
259			my $this_user = $users->search( $key => $args->{$key} )->first \|\| return;
260
261			$this_user->delete \|\| croak "can't delete user\n";
262
263			return $users->dbi_commit \|\| croak "can't commit";
264			}
265
266	dpavlin	29	=head2 add_message_to_list
267	dpavlin	24
268			Adds message to one list's queue for later sending.
269
270	dpavlin	29	$nos->add_message_to_list(
271	dpavlin	24	list => 'My list',
272	dpavlin	36	message => 'Subject: welcome to list
273	dpavlin	38
274	dpavlin	24	This is example message
275			',
276			);
277
278			On success returns ID of newly created (or existing) message.
279
280	dpavlin	36	Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
281			will be automatically generated, but if you want to use own headers, just
282			include them in messages.
283
284	dpavlin	24	=cut
285
286	dpavlin	29	sub add_message_to_list {
287	dpavlin	24	my $self = shift;
288
289			my $args = {@_};
290
291	dpavlin	52	my $list_name = lc($args->{'list'}) \|\| confess "need list name";
292	dpavlin	24	my $message_text = $args->{'message'} \|\| croak "need message";
293
294	dpavlin	29	my $m = Email::Simple->new($message_text) \|\| croak "can't parse message";
295
296	dpavlin	32	unless( $m->header('Subject') ) {
297			warn "message doesn't have Subject header\n";
298			return;
299			}
300	dpavlin	29
301	dpavlin	24	my $lists = $self->{'loader'}->find_class('lists');
302
303			my $this_list = $lists->search(
304			name => $list_name,
305			)->first \|\| croak "can't find list $list_name";
306
307			my $messages = $self->{'loader'}->find_class('messages');
308
309			my $this_message = $messages->find_or_create({
310			message => $message_text
311			}) \|\| croak "can't insert message";
312
313			$this_message->dbi_commit() \|\| croak "can't add message";
314
315			my $queue = $self->{'loader'}->find_class('queue');
316
317			$queue->find_or_create({
318			message_id => $this_message->id,
319			list_id => $this_list->id,
320			}) \|\| croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
321
322			$queue->dbi_commit \|\| croak "can't add message to list ",$this_list->name;
323
324			return $this_message->id;
325			}
326
327
328	dpavlin	22	=head2 send_queued_messages
329	dpavlin	20
330	dpavlin	22	Send queued messages or just ones for selected list
331	dpavlin	20
332	dpavlin	49	$nos->send_queued_messages(
333			list => 'My list',
334			driver => 'smtp',
335			sleep => 3,
336			);
337	dpavlin	20
338	dpavlin	47	Second option is driver which will be used for e-mail delivery. If not
339			specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
340
341			Other valid drivers are:
342
343			=over 10
344
345			=item smtp
346
347			Send e-mail using SMTP server at 127.0.0.1
348
349			=back
350
351	dpavlin	49	Default sleep wait between two messages is 3 seconds.
352
353	dpavlin	21	=cut
354	dpavlin	20
355	dpavlin	22	sub send_queued_messages {
356	dpavlin	21	my $self = shift;
357	dpavlin	20
358	dpavlin	49	my $arg = {@_};
359	dpavlin	20
360	dpavlin	52	my $list_name = lc($arg->{'list'}) \|\| '';
361	dpavlin	49	my $driver = $arg->{'driver'} \|\| '';
362			my $sleep = $arg->{'sleep'};
363			$sleep \|\|= 3 unless defined($sleep);
364	dpavlin	47
365	dpavlin	49	my $email_send_driver = 'Email::Send::IO';
366			my @email_send_options;
367
368	dpavlin	47	if (lc($driver) eq 'smtp') {
369			$email_send_driver = 'Email::Send::SMTP';
370			@email_send_options = ['127.0.0.1'];
371	dpavlin	52	} else {
372			warn "dumping all messages to STDERR\n";
373	dpavlin	47	}
374
375	dpavlin	22	my $lists = $self->{'loader'}->find_class('lists');
376			my $queue = $self->{'loader'}->find_class('queue');
377			my $user_list = $self->{'loader'}->find_class('user_list');
378			my $sent = $self->{'loader'}->find_class('sent');
379	dpavlin	20
380	dpavlin	22	my $my_q;
381			if ($list_name ne '') {
382			my $l_id = $lists->search_like( name => $list_name )->first \|\|
383			croak "can't find list $list_name";
384			$my_q = $queue->search_like( list_id => $l_id ) \|\|
385			croak "can't find list $list_name";
386			} else {
387			$my_q = $queue->retrieve_all;
388			}
389	dpavlin	20
390	dpavlin	22	while (my $m = $my_q->next) {
391			next if ($m->all_sent);
392	dpavlin	20
393	dpavlin	22	print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
394			my $msg = $m->message_id->message;
395	dpavlin	20
396	dpavlin	22	foreach my $u ($user_list->search(list_id => $m->list_id)) {
397	dpavlin	20
398	dpavlin	29	my $to_email = $u->user_id->email;
399
400	dpavlin	32	my ($from,$domain) = split(/@/, $u->list_id->email, 2);
401
402	dpavlin	22	if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
403	dpavlin	29	print "SKIP $to_email message allready sent\n";
404	dpavlin	22	} else {
405	dpavlin	32	print "=> $to_email\n";
406	dpavlin	20
407	dpavlin	32	my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
408	dpavlin	36	my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
409	dpavlin	32
410	dpavlin	29	my $hash = $auth->generate_hash( $to_email );
411	dpavlin	20
412	dpavlin	47	my $from_addr;
413	dpavlin	49	my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
414	dpavlin	48
415	dpavlin	47	$from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
416			$from_addr .= '<' . $from_email_only . '>';
417			my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
418	dpavlin	29
419	dpavlin	32	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
420	dpavlin	29
421	dpavlin	49	$m_obj->header_set('Return-Path', $from_email_only) \|\| croak "can't set Return-Path: header";
422			$m_obj->header_set('Sender', $from_email_only) \|\| croak "can't set Sender: header";
423			$m_obj->header_set('Errors-To', $from_email_only) \|\| croak "can't set Errors-To: header";
424	dpavlin	47	$m_obj->header_set('From', $from_addr) \|\| croak "can't set From: header";
425	dpavlin	32	$m_obj->header_set('To', $to) \|\| croak "can't set To: header";
426	dpavlin	29
427	dpavlin	38	$m_obj->header_set('X-Nos-Version', $VERSION);
428			$m_obj->header_set('X-Nos-Hash', $hash);
429
430	dpavlin	47	# really send e-mail
431			if (@email_send_options) {
432			send $email_send_driver => $m_obj->as_string, @email_send_options;
433			} else {
434			send $email_send_driver => $m_obj->as_string;
435			}
436	dpavlin	22
437			$sent->create({
438			message_id => $m->message_id,
439			user_id => $u->user_id,
440	dpavlin	36	hash => $hash,
441	dpavlin	22	});
442			$sent->dbi_commit;
443	dpavlin	49
444			if ($sleep) {
445			warn "sleeping $sleep seconds\n";
446			sleep($sleep);
447			}
448	dpavlin	22	}
449			}
450			$m->all_sent(1);
451			$m->update;
452			$m->dbi_commit;
453			}
454
455	dpavlin	20	}
456
457	dpavlin	29	=head2 inbox_message
458
459			Receive single message for list's inbox.
460
461	dpavlin	36	my $ok = $nos->inbox_message(
462			list => 'My list',
463			message => $message,
464			);
465	dpavlin	29
466			=cut
467
468			sub inbox_message {
469			my $self = shift;
470
471	dpavlin	36	my $arg = {@_};
472	dpavlin	29
473	dpavlin	36	return unless ($arg->{'message'});
474			croak "need list name" unless ($arg->{'list'});
475	dpavlin	29
476	dpavlin	52	$arg->{'list'} = lc($arg->{'list'});
477
478	dpavlin	37	my $this_list = $self->_get_list($arg->{'list'}) \|\| croak "can't find list ".$arg->{'list'}."\n";
479
480	dpavlin	36	my $m = Email::Simple->new($arg->{'message'}) \|\| croak "can't parse message";
481
482			my $to = $m->header('To') \|\| die "can't find To: address in incomming message\n";
483
484	dpavlin	48	my $return_path = $m->header('Return-Path') \|\| '';
485
486	dpavlin	36	my @addrs = Email::Address->parse( $to );
487
488			die "can't parse To: $to address\n" unless (@addrs);
489
490			my $hl = $self->{'hash_len'} \|\| confess "no hash_len?";
491
492			my $hash;
493
494			foreach my $a (@addrs) {
495	dpavlin	52	if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
496	dpavlin	36	$hash = $1;
497			last;
498			}
499			}
500
501	dpavlin	50	#warn "can't find hash in e-mail $to\n" unless ($hash);
502	dpavlin	36
503			my $sent = $self->{'loader'}->find_class('sent');
504
505			# will use null if no matching message_id is found
506	dpavlin	50	my $sent_msg;
507			$sent_msg = $sent->search( hash => $hash )->first if ($hash);
508	dpavlin	36
509	dpavlin	37	my ($message_id, $user_id) = (undef, undef); # init with NULL
510	dpavlin	36
511	dpavlin	37	if ($sent_msg) {
512			$message_id = $sent_msg->message_id \|\| carp "no message_id";
513			$user_id = $sent_msg->user_id \|\| carp "no user_id";
514	dpavlin	47	} else {
515	dpavlin	50	#warn "can't find sender with hash $hash\n";
516			my $users = $self->{'loader'}->find_class('users');
517			my $from = $m->header('From');
518			$from = $1 if ($from =~ m/<(.*)>/);
519	dpavlin	52	my $this_user = $users->search( email => lc($from) )->first;
520	dpavlin	50	$user_id = $this_user->id if ($this_user);
521	dpavlin	37	}
522
523
524			my $is_bounce = 0;
525
526	dpavlin	49	if ($return_path eq '<>' \|\| $return_path eq '') {
527	dpavlin	47	no warnings;
528			my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
529			$arg->{'message'}, { report_non_bounces=>1 },
530			) };
531	dpavlin	50	#warn "can't check if this message is bounce!" if ($@);
532	dpavlin	47
533			$is_bounce++ if ($bounce && $bounce->is_bounce);
534			}
535	dpavlin	37
536			my $received = $self->{'loader'}->find_class('received');
537
538			my $this_received = $received->find_or_create({
539			user_id => $user_id,
540			list_id => $this_list->id,
541			message_id => $message_id,
542			message => $arg->{'message'},
543			bounced => $is_bounce,
544			}) \|\| croak "can't insert received message";
545
546			$this_received->dbi_commit;
547
548	dpavlin	49	# print "message_id: ",($message_id \|\| "not found")," -- $is_bounce\n";
549	dpavlin	29	}
550
551
552	dpavlin	30	=head1 INTERNAL METHODS
553
554			Beware of dragons! You shouldn't need to call those methods directly.
555
556			=head2 _add_list
557
558			Create new list
559
560			my $list_obj = $nos->_add_list(
561			list => 'My list',
562	dpavlin	47	from => 'Outgoing from comment',
563	dpavlin	30	email => 'my-list@example.com',
564			);
565
566			Returns C<Class::DBI> object for created list.
567
568	dpavlin	38	C<email> address can be with domain or without it if your
569			MTA appends it. There is no checking for validity of your
570			list e-mail. Flexibility comes with resposibility, so please
571			feed correct (and configured) return addresses.
572
573	dpavlin	30	=cut
574
575			sub _add_list {
576			my $self = shift;
577
578			my $arg = {@_};
579
580	dpavlin	52	my $name = lc($arg->{'list'}) \|\| confess "can't add list without name";
581			my $email = lc($arg->{'email'}) \|\| confess "can't add list without e-mail";
582	dpavlin	47	my $from_addr = $arg->{'from'};
583	dpavlin	30
584			my $lists = $self->{'loader'}->find_class('lists');
585
586			my $l = $lists->find_or_create({
587			name => $name,
588			email => $email,
589			});
590	dpavlin	47
591	dpavlin	30	croak "can't add list $name\n" unless ($l);
592
593	dpavlin	47	if ($from_addr && $l->from_addr ne $from_addr) {
594			$l->from_addr($from_addr);
595			$l->update;
596			}
597
598	dpavlin	30	$l->dbi_commit;
599
600			return $l;
601
602			}
603
604
605			=head2 _get_list
606
607			Get list C<Class::DBI> object.
608
609			my $list_obj = $nos->check_list('My list');
610
611			Returns false on failure.
612
613			=cut
614
615			sub _get_list {
616			my $self = shift;
617
618			my $name = shift \|\| return;
619
620	dpavlin	31	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
621	dpavlin	30
622	dpavlin	52	return $lists->search({ name => lc($name) })->first;
623	dpavlin	30	}
624
625	dpavlin	39	###
626			### SOAP
627			###
628	dpavlin	30
629	dpavlin	39	package Nos::SOAP;
630
631	dpavlin	43	use Carp;
632
633	dpavlin	39	=head1 SOAP methods
634
635			This methods are thin wrappers to provide SOAP calls. They are grouped in
636			C<Nos::SOAP> package which is in same F<Nos.pm> module file.
637
638			Usually, you want to use named variables in your SOAP calls if at all
639			possible.
640
641			However, if you have broken SOAP library (like PHP SOAP class from PEAR)
642			you will want to use positional arguments (in same order as documented for
643			methods below).
644
645			=cut
646
647			my $nos;
648
649			sub new {
650			my $class = shift;
651			my $self = {@_};
652			bless($self, $class);
653
654			$nos = new Nos( @_ ) \|\| die "can't create Nos object";
655
656			$self ? return $self : return undef;
657			}
658
659
660			=head2 NewList
661
662			$message_id = NewList(
663			list => 'My list',
664			email => 'my-list@example.com'
665			);
666
667			=cut
668
669			sub NewList {
670			my $self = shift;
671
672			if ($_[0] !~ m/^HASH/) {
673			return $nos->new_list(
674			list => $_[0], email => $_[1],
675			);
676			} else {
677			return $nos->new_list( %{ shift @_ } );
678			}
679			}
680
681	dpavlin	43
682	dpavlin	39	=head2 AddMemberToList
683
684			$member_id = AddMemberToList(
685	dpavlin	43	list => 'My list',
686			email => 'e-mail@example.com',
687			name => 'Full Name'
688	dpavlin	39	);
689
690			=cut
691
692			sub AddMemberToList {
693			my $self = shift;
694
695			if ($_[0] !~ m/^HASH/) {
696			return $nos->add_member_to_list(
697			list => $_[0], email => $_[1], name => $_[2],
698			);
699			} else {
700			return $nos->add_member_to_list( %{ shift @_ } );
701			}
702			}
703
704	dpavlin	43
705			=head2 ListMembers
706
707			my @members = ListMembers(
708			list => 'My list',
709			);
710
711			Returns array of hashes with user informations, see C<list_members>.
712
713			=cut
714
715			sub ListMembers {
716			my $self = shift;
717
718			my $list_name;
719
720			if ($_[0] !~ m/^HASH/) {
721			$list_name = shift;
722			} else {
723			$list_name = $_[0]->{'list'};
724			}
725
726			return $nos->list_members( list => $list_name );
727			}
728
729	dpavlin	39	=head2 AddMessageToList
730
731			$message_id = AddMessageToList(
732			list => 'My list',
733			message => 'From: My list...'
734			);
735
736			=cut
737
738			sub AddMessageToList {
739			my $self = shift;
740
741			if ($_[0] !~ m/^HASH/) {
742			return $nos->add_message_to_list(
743			list => $_[0], message => $_[1],
744			);
745			} else {
746			return $nos->add_message_to_list( %{ shift @_ } );
747			}
748			}
749
750
751			###
752
753	dpavlin	25	=head1 EXPORT
754	dpavlin	20
755	dpavlin	27	Nothing.
756	dpavlin	20
757			=head1 SEE ALSO
758
759			mailman, ezmlm, sympa, L<Mail::Salsa>
760
761	dpavlin	25
762	dpavlin	20	=head1 AUTHOR
763
764			Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
765
766	dpavlin	25
767	dpavlin	20	=head1 COPYRIGHT AND LICENSE
768
769			Copyright (C) 2005 by Dobrica Pavlinusic
770
771			This library is free software; you can redistribute it and/or modify
772			it under the same terms as Perl itself, either Perl version 5.8.4 or,
773			at your option, any later version of Perl 5 you may have available.
774
775
776			=cut
777	dpavlin	39
778			1;