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->{'list'});

        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 = $arg->{'email'} || croak "can't add user without e-mail";
        my $name = $arg->{'name'} || '';
        my $list_name = $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 = $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'});

        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 = $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 = $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'];
        }
        warn "using $driver [$email_send_driver]\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'});

        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})@/) {
                        $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->search( hash => $hash )->first;

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