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 list_members

 my @members = list_members(
        list => 'My list',
 );

Returns array of hashes with user informations like this:

 $member = {
        full_name => 'Dobrica Pavlinusic',
        email => 'dpavlin@rot13.org
 }

=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 || croak "can't find list $list_name\n";

        my @results;

        foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
                my $row = {
                        full_name => $user_on_list->user_id->full_name,
                        email => $user_on_list->user_id->email,
                };

                push @results, $row;
        }

        return @results;

}


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


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