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

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->full_name ne $name) {
                $this_user->full_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 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->full_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";
        }

print "message_id: ",($message_id || "not found"),"\n";

        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;

        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;

=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 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	29	our $VERSION = '0.3';
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	33	if ($name && $this_user->full_name ne $name) {
162			$this_user->full_name($name \|\| '');
163			$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	29	=head2 add_message_to_list
179	dpavlin	24
180			Adds message to one list's queue for later sending.
181
182	dpavlin	29	$nos->add_message_to_list(
183	dpavlin	24	list => 'My list',
184	dpavlin	36	message => 'Subject: welcome to list
185	dpavlin	38
186	dpavlin	24	This is example message
187			',
188			);
189
190			On success returns ID of newly created (or existing) message.
191
192	dpavlin	36	Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
193			will be automatically generated, but if you want to use own headers, just
194			include them in messages.
195
196	dpavlin	24	=cut
197
198	dpavlin	29	sub add_message_to_list {
199	dpavlin	24	my $self = shift;
200
201			my $args = {@_};
202
203			my $list_name = $args->{'list'} \|\| confess "need list name";
204			my $message_text = $args->{'message'} \|\| croak "need message";
205
206	dpavlin	29	my $m = Email::Simple->new($message_text) \|\| croak "can't parse message";
207
208	dpavlin	32	unless( $m->header('Subject') ) {
209			warn "message doesn't have Subject header\n";
210			return;
211			}
212	dpavlin	29
213	dpavlin	24	my $lists = $self->{'loader'}->find_class('lists');
214
215			my $this_list = $lists->search(
216			name => $list_name,
217			)->first \|\| croak "can't find list $list_name";
218
219			my $messages = $self->{'loader'}->find_class('messages');
220
221			my $this_message = $messages->find_or_create({
222			message => $message_text
223			}) \|\| croak "can't insert message";
224
225			$this_message->dbi_commit() \|\| croak "can't add message";
226
227			my $queue = $self->{'loader'}->find_class('queue');
228
229			$queue->find_or_create({
230			message_id => $this_message->id,
231			list_id => $this_list->id,
232			}) \|\| croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
233
234			$queue->dbi_commit \|\| croak "can't add message to list ",$this_list->name;
235
236			return $this_message->id;
237			}
238
239
240	dpavlin	22	=head2 send_queued_messages
241	dpavlin	20
242	dpavlin	22	Send queued messages or just ones for selected list
243	dpavlin	20
244	dpavlin	24	$nos->send_queued_messages("My list");
245	dpavlin	20
246	dpavlin	21	=cut
247	dpavlin	20
248	dpavlin	22	sub send_queued_messages {
249	dpavlin	21	my $self = shift;
250	dpavlin	20
251	dpavlin	22	my $list_name = shift;
252	dpavlin	20
253	dpavlin	22	my $lists = $self->{'loader'}->find_class('lists');
254			my $queue = $self->{'loader'}->find_class('queue');
255			my $user_list = $self->{'loader'}->find_class('user_list');
256			my $sent = $self->{'loader'}->find_class('sent');
257	dpavlin	20
258	dpavlin	22	my $my_q;
259			if ($list_name ne '') {
260			my $l_id = $lists->search_like( name => $list_name )->first \|\|
261			croak "can't find list $list_name";
262			$my_q = $queue->search_like( list_id => $l_id ) \|\|
263			croak "can't find list $list_name";
264			} else {
265			$my_q = $queue->retrieve_all;
266			}
267	dpavlin	20
268	dpavlin	22	while (my $m = $my_q->next) {
269			next if ($m->all_sent);
270	dpavlin	20
271	dpavlin	22	print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
272			my $msg = $m->message_id->message;
273	dpavlin	20
274	dpavlin	22	foreach my $u ($user_list->search(list_id => $m->list_id)) {
275	dpavlin	20
276	dpavlin	29	my $to_email = $u->user_id->email;
277
278	dpavlin	32	my ($from,$domain) = split(/@/, $u->list_id->email, 2);
279
280	dpavlin	22	if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281	dpavlin	29	print "SKIP $to_email message allready sent\n";
282	dpavlin	22	} else {
283	dpavlin	32	print "=> $to_email\n";
284	dpavlin	20
285	dpavlin	32	my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
286	dpavlin	36	my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
287	dpavlin	32
288	dpavlin	29	my $hash = $auth->generate_hash( $to_email );
289	dpavlin	20
290	dpavlin	32	my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
291	dpavlin	29	my $to = $u->user_id->full_name . " <$to_email>";
292
293	dpavlin	32	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
294	dpavlin	29
295	dpavlin	32	$m_obj->header_set('From', $from) \|\| croak "can't set From: header";
296			$m_obj->header_set('To', $to) \|\| croak "can't set To: header";
297	dpavlin	29
298	dpavlin	38	$m_obj->header_set('X-Nos-Version', $VERSION);
299			$m_obj->header_set('X-Nos-Hash', $hash);
300
301	dpavlin	22	# FIXME do real sending :-)
302	dpavlin	32	send IO => $m_obj->as_string;
303	dpavlin	22
304			$sent->create({
305			message_id => $m->message_id,
306			user_id => $u->user_id,
307	dpavlin	36	hash => $hash,
308	dpavlin	22	});
309			$sent->dbi_commit;
310			}
311			}
312			$m->all_sent(1);
313			$m->update;
314			$m->dbi_commit;
315			}
316
317	dpavlin	20	}
318
319	dpavlin	29	=head2 inbox_message
320
321			Receive single message for list's inbox.
322
323	dpavlin	36	my $ok = $nos->inbox_message(
324			list => 'My list',
325			message => $message,
326			);
327	dpavlin	29
328			=cut
329
330			sub inbox_message {
331			my $self = shift;
332
333	dpavlin	36	my $arg = {@_};
334	dpavlin	29
335	dpavlin	36	return unless ($arg->{'message'});
336			croak "need list name" unless ($arg->{'list'});
337	dpavlin	29
338	dpavlin	37	my $this_list = $self->_get_list($arg->{'list'}) \|\| croak "can't find list ".$arg->{'list'}."\n";
339
340	dpavlin	36	my $m = Email::Simple->new($arg->{'message'}) \|\| croak "can't parse message";
341
342			my $to = $m->header('To') \|\| die "can't find To: address in incomming message\n";
343
344			my @addrs = Email::Address->parse( $to );
345
346			die "can't parse To: $to address\n" unless (@addrs);
347
348			my $hl = $self->{'hash_len'} \|\| confess "no hash_len?";
349
350			my $hash;
351
352			foreach my $a (@addrs) {
353			if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
354			$hash = $1;
355			last;
356			}
357			}
358
359			croak "can't find hash in e-mail $to\n" unless ($hash);
360
361			my $sent = $self->{'loader'}->find_class('sent');
362
363			# will use null if no matching message_id is found
364	dpavlin	37	my $sent_msg = $sent->search( hash => $hash )->first;
365	dpavlin	36
366	dpavlin	37	my ($message_id, $user_id) = (undef, undef); # init with NULL
367	dpavlin	36
368	dpavlin	37	if ($sent_msg) {
369			$message_id = $sent_msg->message_id \|\| carp "no message_id";
370			$user_id = $sent_msg->user_id \|\| carp "no user_id";
371			}
372
373			print "message_id: ",($message_id \|\| "not found"),"\n";
374
375			my $is_bounce = 0;
376
377			my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
378			$arg->{'message'}, { report_non_bounces=>1 },
379			) };
380			carp "can't check if this message is bounce!" if ($@);
381
382			$is_bounce++ if ($bounce && $bounce->is_bounce);
383
384			my $received = $self->{'loader'}->find_class('received');
385
386			my $this_received = $received->find_or_create({
387			user_id => $user_id,
388			list_id => $this_list->id,
389			message_id => $message_id,
390			message => $arg->{'message'},
391			bounced => $is_bounce,
392			}) \|\| croak "can't insert received message";
393
394			$this_received->dbi_commit;
395
396	dpavlin	36	warn "inbox is not yet implemented";
397	dpavlin	29	}
398
399
400	dpavlin	30	=head1 INTERNAL METHODS
401
402			Beware of dragons! You shouldn't need to call those methods directly.
403
404			=head2 _add_list
405
406			Create new list
407
408			my $list_obj = $nos->_add_list(
409			list => 'My list',
410			email => 'my-list@example.com',
411			);
412
413			Returns C<Class::DBI> object for created list.
414
415	dpavlin	38	C<email> address can be with domain or without it if your
416			MTA appends it. There is no checking for validity of your
417			list e-mail. Flexibility comes with resposibility, so please
418			feed correct (and configured) return addresses.
419
420	dpavlin	30	=cut
421
422			sub _add_list {
423			my $self = shift;
424
425			my $arg = {@_};
426
427			my $name = $arg->{'list'} \|\| confess "can't add list without name";
428			my $email = $arg->{'email'} \|\| confess "can't add list without e-mail";
429
430			my $lists = $self->{'loader'}->find_class('lists');
431
432			my $l = $lists->find_or_create({
433			name => $name,
434			email => $email,
435			});
436
437			croak "can't add list $name\n" unless ($l);
438
439			$l->dbi_commit;
440
441			return $l;
442
443			}
444
445
446			=head2 _get_list
447
448			Get list C<Class::DBI> object.
449
450			my $list_obj = $nos->check_list('My list');
451
452			Returns false on failure.
453
454			=cut
455
456			sub _get_list {
457			my $self = shift;
458
459			my $name = shift \|\| return;
460
461	dpavlin	31	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
462	dpavlin	30
463	dpavlin	31	return $lists->search({ name => $name })->first;
464	dpavlin	30	}
465
466	dpavlin	39	###
467			### SOAP
468			###
469	dpavlin	30
470	dpavlin	39	package Nos::SOAP;
471
472			=head1 SOAP methods
473
474			This methods are thin wrappers to provide SOAP calls. They are grouped in
475			C<Nos::SOAP> package which is in same F<Nos.pm> module file.
476
477			Usually, you want to use named variables in your SOAP calls if at all
478			possible.
479
480			However, if you have broken SOAP library (like PHP SOAP class from PEAR)
481			you will want to use positional arguments (in same order as documented for
482			methods below).
483
484			=cut
485
486			my $nos;
487
488			sub new {
489			my $class = shift;
490			my $self = {@_};
491			bless($self, $class);
492
493			$nos = new Nos( @_ ) \|\| die "can't create Nos object";
494
495			$self ? return $self : return undef;
496			}
497
498
499			=head2 NewList
500
501			$message_id = NewList(
502			list => 'My list',
503			email => 'my-list@example.com'
504			);
505
506			=cut
507
508			sub NewList {
509			my $self = shift;
510
511			if ($_[0] !~ m/^HASH/) {
512			return $nos->new_list(
513			list => $_[0], email => $_[1],
514			);
515			} else {
516			return $nos->new_list( %{ shift @_ } );
517			}
518			}
519
520			=head2 AddMemberToList
521
522			$member_id = AddMemberToList(
523			list => "My list",
524			email => "e-mail@example.com",
525			name => "Full Name"
526			);
527
528			=cut
529
530			sub AddMemberToList {
531			my $self = shift;
532
533			if ($_[0] !~ m/^HASH/) {
534			return $nos->add_member_to_list(
535			list => $_[0], email => $_[1], name => $_[2],
536			);
537			} else {
538			return $nos->add_member_to_list( %{ shift @_ } );
539			}
540			}
541
542			=head2 AddMessageToList
543
544			$message_id = AddMessageToList(
545			list => 'My list',
546			message => 'From: My list...'
547			);
548
549			=cut
550
551			sub AddMessageToList {
552			my $self = shift;
553
554			if ($_[0] !~ m/^HASH/) {
555			return $nos->add_message_to_list(
556			list => $_[0], message => $_[1],
557			);
558			} else {
559			return $nos->add_message_to_list( %{ shift @_ } );
560			}
561			}
562
563
564			###
565
566	dpavlin	25	=head1 EXPORT
567	dpavlin	20
568	dpavlin	27	Nothing.
569	dpavlin	20
570			=head1 SEE ALSO
571
572			mailman, ezmlm, sympa, L<Mail::Salsa>
573
574	dpavlin	25
575	dpavlin	20	=head1 AUTHOR
576
577			Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
578
579	dpavlin	25
580	dpavlin	20	=head1 COPYRIGHT AND LICENSE
581
582			Copyright (C) 2005 by Dobrica Pavlinusic
583
584			This library is free software; you can redistribute it and/or modify
585			it under the same terms as Perl itself, either Perl version 5.8.4 or,
586			at your option, any later version of Perl 5 you may have available.
587
588
589			=cut
590	dpavlin	39
591			1;