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;
use Data::Dumper;

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

print Dumper($this_user);

        $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("My list");

=cut

sub send_queued_messages {
        my $self = shift;

        my $list_name = shift;

        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 = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
                                my $to = $u->user_id->name . " <$to_email>";

                                my $m_obj = Email::Simple->new($msg) || croak "can't parse message";

                                $m_obj->header_set('From', $from) || 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);

                                # FIXME do real sending :-)
                                send IO => $m_obj->as_string;

                                $sent->create({
                                        message_id => $m->message_id,
                                        user_id => $u->user_id,
                                        hash => $hash,
                                });
                                $sent->dbi_commit;
                        }
                }
                $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 @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;
                }
        }

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


        my $is_bounce = 0;

        my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
                $arg->{'message'}, { report_non_bounces=>1 },
        ) };
        carp "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";


        warn "inbox is not yet implemented";
}


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

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