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	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	our $VERSION = '0.4';
20
21	use Class::DBI::Loader;
22	use Email::Valid;
23	use Email::Send;
24	use Carp;
25	use Email::Auth::AddressHash;
26	use Email::Simple;
27	use Email::Address;
28	use Mail::DeliveryStatus::BounceParser;
29	use Data::Dumper;
30
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	hash_len => 8,
57	);
58
59	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
62	=cut
63
64	sub new {
65	my $class = shift;
66	my $self = {@_};
67	bless($self, $class);
68
69	croak "need at least dsn" unless ($self->{'dsn'});
70
71	$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	) \|\| croak "can't init Class::DBI::Loader";
81
82	$self->{'hash_len'} \|\|= 8;
83
84	$self ? return $self : return undef;
85	}
86
87
88	=head2 new_list
89
90	Create new list. Required arguments are name of C<list> and
91	C<email> address.
92
93	$nos->new_list(
94	list => 'My list',
95	email => 'my-list@example.com',
96	);
97
98	Returns ID of newly created list.
99
100	Calls internally L<_add_list>, see details there.
101
102	=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	=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	Return member ID if user is added.
133
134	=cut
135
136	sub add_member_to_list {
137	my $self = shift;
138
139	my $arg = {@_};
140
141	my $email = $arg->{'email'} \|\| croak "can't add user without e-mail";
142	my $name = $arg->{'name'} \|\| '';
143	my $list_name = $arg->{'list'} \|\| croak "need list name";
144
145	my $list = $self->_get_list($list_name) \|\| croak "list $list_name doesn't exist";
146
147	if (! Email::Valid->address($email)) {
148	carp "SKIPPING $name <$email>\n";
149	return 0;
150	}
151
152	carp "# $name <$email>\n" if ($self->{'verbose'});
153
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	if ($name && $this_user->name ne $name) {
162	$this_user->name($name \|\| '');
163	$this_user->update;
164	}
165
166	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	return $this_user->id;
176	}
177
178	=head2 list_members
179
180	List all members of some list.
181
182	my @members = list_members(
183	list => 'My list',
184	);
185
186	Returns array of hashes with user informations like this:
187
188	$member = {
189	name => 'Dobrica Pavlinusic',
190	email => 'dpavlin@rot13.org
191	}
192
193	If list is not found, returns false.
194
195	=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	my $this_list = $lists->search( name => $list_name )->first \|\| return;
208
209	my @results;
210
211	foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
212	my $row = {
213	name => $user_on_list->user_id->name,
214	email => $user_on_list->user_id->email,
215	};
216
217	push @results, $row;
218	}
219
220	return @results;
221
222	}
223
224
225	=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	=head2 add_message_to_list
263
264	Adds message to one list's queue for later sending.
265
266	$nos->add_message_to_list(
267	list => 'My list',
268	message => 'Subject: welcome to list
269
270	This is example message
271	',
272	);
273
274	On success returns ID of newly created (or existing) message.
275
276	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	=cut
281
282	sub add_message_to_list {
283	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	my $m = Email::Simple->new($message_text) \|\| croak "can't parse message";
291
292	unless( $m->header('Subject') ) {
293	warn "message doesn't have Subject header\n";
294	return;
295	}
296
297	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	=head2 send_queued_messages
325
326	Send queued messages or just ones for selected list
327
328	$nos->send_queued_messages("My list");
329
330	=cut
331
332	sub send_queued_messages {
333	my $self = shift;
334
335	my $list_name = shift;
336
337	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
342	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
352	while (my $m = $my_q->next) {
353	next if ($m->all_sent);
354
355	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
358	foreach my $u ($user_list->search(list_id => $m->list_id)) {
359
360	my $to_email = $u->user_id->email;
361
362	my ($from,$domain) = split(/@/, $u->list_id->email, 2);
363
364	if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
365	print "SKIP $to_email message allready sent\n";
366	} else {
367	print "=> $to_email\n";
368
369	my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
370	my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
371
372	my $hash = $auth->generate_hash( $to_email );
373
374	my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
375	my $to = $u->user_id->name . " <$to_email>";
376
377	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
378
379	$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
382	$m_obj->header_set('X-Nos-Version', $VERSION);
383	$m_obj->header_set('X-Nos-Hash', $hash);
384
385	# FIXME do real sending :-)
386	send IO => $m_obj->as_string;
387
388	$sent->create({
389	message_id => $m->message_id,
390	user_id => $u->user_id,
391	hash => $hash,
392	});
393	$sent->dbi_commit;
394	}
395	}
396	$m->all_sent(1);
397	$m->update;
398	$m->dbi_commit;
399	}
400
401	}
402
403	=head2 inbox_message
404
405	Receive single message for list's inbox.
406
407	my $ok = $nos->inbox_message(
408	list => 'My list',
409	message => $message,
410	);
411
412	=cut
413
414	sub inbox_message {
415	my $self = shift;
416
417	my $arg = {@_};
418
419	return unless ($arg->{'message'});
420	croak "need list name" unless ($arg->{'list'});
421
422	my $this_list = $self->_get_list($arg->{'list'}) \|\| croak "can't find list ".$arg->{'list'}."\n";
423
424	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	my $sent_msg = $sent->search( hash => $hash )->first;
449
450	my ($message_id, $user_id) = (undef, undef); # init with NULL
451
452	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	print "message_id: ",($message_id \|\| "not found")," -- $is_bounce\n";
480
481
482	warn "inbox is not yet implemented";
483	}
484
485
486	=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	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	=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	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
548
549	return $lists->search({ name => $name })->first;
550	}
551
552	###
553	### SOAP
554	###
555
556	package Nos::SOAP;
557
558	use Carp;
559
560	=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
609	=head2 AddMemberToList
610
611	$member_id = AddMemberToList(
612	list => 'My list',
613	email => 'e-mail@example.com',
614	name => 'Full Name'
615	);
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
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	=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	=head1 EXPORT
681
682	Nothing.
683
684	=head1 SEE ALSO
685
686	mailman, ezmlm, sympa, L<Mail::Salsa>
687
688
689	=head1 AUTHOR
690
691	Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
692
693
694	=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
705	1;