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 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> defined length of hash which will be added to each
outgoing e-mail message.

=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

 $nos->new_list(
        list => 'My list",
        email => 'my-list@example.com',
 );

Returns ID of newly created list.

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

                                # 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 $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 $message_id = $sent->search( hash => $hash )->first->message_id;

print "message_id: $message_id\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.

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


=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	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.3';
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 Data::Dumper;
29
30	=head1 NAME
31
32	Nos - Notice Sender core module
33
34	=head1 SYNOPSIS
35
36	use Nos;
37	my $nos = new Nos();
38
39	=head1 DESCRIPTION
40
41	Core module for notice sender's functionality.
42
43	=head1 METHODS
44
45	=head2 new
46
47	Create new instance specifing database, user, password and options.
48
49	my $nos = new Nos(
50	dsn => 'dbi:Pg:dbname=notices',
51	user => 'dpavlin',
52	passwd => '',
53	debug => 1,
54	verbose => 1,
55	hash_len => 8,
56	);
57
58	Parametar C<hash_len> defined length of hash which will be added to each
59	outgoing e-mail message.
60
61	=cut
62
63	sub new {
64	my $class = shift;
65	my $self = {@_};
66	bless($self, $class);
67
68	croak "need at least dsn" unless ($self->{'dsn'});
69
70	$self->{'loader'} = Class::DBI::Loader->new(
71	debug => $self->{'debug'},
72	dsn => $self->{'dsn'},
73	user => $self->{'user'},
74	password => $self->{'passwd'},
75	namespace => "Nos",
76	# additional_classes => qw/Class::DBI::AbstractSearch/,
77	# additional_base_classes => qw/My::Stuff/,
78	relationships => 1,
79	) \|\| croak "can't init Class::DBI::Loader";
80
81	$self->{'hash_len'} \|\|= 8;
82
83	$self ? return $self : return undef;
84	}
85
86
87	=head2 new_list
88
89	Create new list
90
91	$nos->new_list(
92	list => 'My list",
93	email => 'my-list@example.com',
94	);
95
96	Returns ID of newly created list.
97
98	=cut
99
100	sub new_list {
101	my $self = shift;
102
103	my $arg = {@_};
104
105	confess "need list name" unless ($arg->{'list'});
106	confess "need list email" unless ($arg->{'list'});
107
108	my $l = $self->_get_list($arg->{'list'}) \|\|
109	$self->_add_list( @_ ) \|\|
110	return undef;
111
112	return $l->id;
113	}
114
115
116	=head2 add_member_to_list
117
118	Add new member to list
119
120	$nos->add_member_to_list(
121	list => "My list",
122	email => "john.doe@example.com",
123	name => "John A. Doe",
124	);
125
126	C<name> parametar is optional.
127
128	Return member ID if user is added.
129
130	=cut
131
132	sub add_member_to_list {
133	my $self = shift;
134
135	my $arg = {@_};
136
137	my $email = $arg->{'email'} \|\| croak "can't add user without e-mail";
138	my $name = $arg->{'name'} \|\| '';
139	my $list_name = $arg->{'list'} \|\| croak "need list name";
140
141	my $list = $self->_get_list($list_name) \|\| croak "list $list_name doesn't exist";
142
143	if (! Email::Valid->address($email)) {
144	carp "SKIPPING $name <$email>\n";
145	return 0;
146	}
147
148	carp "# $name <$email>\n" if ($self->{'verbose'});
149
150	my $users = $self->{'loader'}->find_class('users');
151	my $user_list = $self->{'loader'}->find_class('user_list');
152
153	my $this_user = $users->find_or_create({
154	email => $email,
155	}) \|\| croak "can't find or create member\n";
156
157	if ($name && $this_user->full_name ne $name) {
158	$this_user->full_name($name \|\| '');
159	$this_user->update;
160	}
161
162	my $user_on_list = $user_list->find_or_create({
163	user_id => $this_user->id,
164	list_id => $list->id,
165	}) \|\| croak "can't add user to list";
166
167	$list->dbi_commit;
168	$this_user->dbi_commit;
169	$user_on_list->dbi_commit;
170
171	return $this_user->id;
172	}
173
174	=head2 add_message_to_list
175
176	Adds message to one list's queue for later sending.
177
178	$nos->add_message_to_list(
179	list => 'My list',
180	message => 'Subject: welcome to list
181
182	This is example message
183	',
184	);
185
186	On success returns ID of newly created (or existing) message.
187
188	Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
189	will be automatically generated, but if you want to use own headers, just
190	include them in messages.
191
192	=cut
193
194	sub add_message_to_list {
195	my $self = shift;
196
197	my $args = {@_};
198
199	my $list_name = $args->{'list'} \|\| confess "need list name";
200	my $message_text = $args->{'message'} \|\| croak "need message";
201
202	my $m = Email::Simple->new($message_text) \|\| croak "can't parse message";
203
204	unless( $m->header('Subject') ) {
205	warn "message doesn't have Subject header\n";
206	return;
207	}
208
209	my $lists = $self->{'loader'}->find_class('lists');
210
211	my $this_list = $lists->search(
212	name => $list_name,
213	)->first \|\| croak "can't find list $list_name";
214
215	my $messages = $self->{'loader'}->find_class('messages');
216
217	my $this_message = $messages->find_or_create({
218	message => $message_text
219	}) \|\| croak "can't insert message";
220
221	$this_message->dbi_commit() \|\| croak "can't add message";
222
223	my $queue = $self->{'loader'}->find_class('queue');
224
225	$queue->find_or_create({
226	message_id => $this_message->id,
227	list_id => $this_list->id,
228	}) \|\| croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
229
230	$queue->dbi_commit \|\| croak "can't add message to list ",$this_list->name;
231
232	return $this_message->id;
233	}
234
235
236	=head2 send_queued_messages
237
238	Send queued messages or just ones for selected list
239
240	$nos->send_queued_messages("My list");
241
242	=cut
243
244	sub send_queued_messages {
245	my $self = shift;
246
247	my $list_name = shift;
248
249	my $lists = $self->{'loader'}->find_class('lists');
250	my $queue = $self->{'loader'}->find_class('queue');
251	my $user_list = $self->{'loader'}->find_class('user_list');
252	my $sent = $self->{'loader'}->find_class('sent');
253
254	my $my_q;
255	if ($list_name ne '') {
256	my $l_id = $lists->search_like( name => $list_name )->first \|\|
257	croak "can't find list $list_name";
258	$my_q = $queue->search_like( list_id => $l_id ) \|\|
259	croak "can't find list $list_name";
260	} else {
261	$my_q = $queue->retrieve_all;
262	}
263
264	while (my $m = $my_q->next) {
265	next if ($m->all_sent);
266
267	print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
268	my $msg = $m->message_id->message;
269
270	foreach my $u ($user_list->search(list_id => $m->list_id)) {
271
272	my $to_email = $u->user_id->email;
273
274	my ($from,$domain) = split(/@/, $u->list_id->email, 2);
275
276	if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
277	print "SKIP $to_email message allready sent\n";
278	} else {
279	print "=> $to_email\n";
280
281	my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
282	my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
283
284	my $hash = $auth->generate_hash( $to_email );
285
286	my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
287	my $to = $u->user_id->full_name . " <$to_email>";
288
289	my $m_obj = Email::Simple->new($msg) \|\| croak "can't parse message";
290
291	$m_obj->header_set('From', $from) \|\| croak "can't set From: header";
292	$m_obj->header_set('To', $to) \|\| croak "can't set To: header";
293
294	# FIXME do real sending :-)
295	send IO => $m_obj->as_string;
296
297	$sent->create({
298	message_id => $m->message_id,
299	user_id => $u->user_id,
300	hash => $hash,
301	});
302	$sent->dbi_commit;
303	}
304	}
305	$m->all_sent(1);
306	$m->update;
307	$m->dbi_commit;
308	}
309
310	}
311
312	=head2 inbox_message
313
314	Receive single message for list's inbox.
315
316	my $ok = $nos->inbox_message(
317	list => 'My list',
318	message => $message,
319	);
320
321	=cut
322
323	sub inbox_message {
324	my $self = shift;
325
326	my $arg = {@_};
327
328	return unless ($arg->{'message'});
329	croak "need list name" unless ($arg->{'list'});
330
331	my $m = Email::Simple->new($arg->{'message'}) \|\| croak "can't parse message";
332
333	my $to = $m->header('To') \|\| die "can't find To: address in incomming message\n";
334
335	my @addrs = Email::Address->parse( $to );
336
337	die "can't parse To: $to address\n" unless (@addrs);
338
339	my $hl = $self->{'hash_len'} \|\| confess "no hash_len?";
340
341	my $hash;
342
343	foreach my $a (@addrs) {
344	if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
345	$hash = $1;
346	last;
347	}
348	}
349
350	croak "can't find hash in e-mail $to\n" unless ($hash);
351
352	my $sent = $self->{'loader'}->find_class('sent');
353
354	# will use null if no matching message_id is found
355	my $message_id = $sent->search( hash => $hash )->first->message_id;
356
357	print "message_id: $message_id\n";
358
359	warn "inbox is not yet implemented";
360	}
361
362
363	=head1 INTERNAL METHODS
364
365	Beware of dragons! You shouldn't need to call those methods directly.
366
367	=head2 _add_list
368
369	Create new list
370
371	my $list_obj = $nos->_add_list(
372	list => 'My list',
373	email => 'my-list@example.com',
374	);
375
376	Returns C<Class::DBI> object for created list.
377
378	=cut
379
380	sub _add_list {
381	my $self = shift;
382
383	my $arg = {@_};
384
385	my $name = $arg->{'list'} \|\| confess "can't add list without name";
386	my $email = $arg->{'email'} \|\| confess "can't add list without e-mail";
387
388	my $lists = $self->{'loader'}->find_class('lists');
389
390	my $l = $lists->find_or_create({
391	name => $name,
392	email => $email,
393	});
394
395	croak "can't add list $name\n" unless ($l);
396
397	$l->dbi_commit;
398
399	return $l;
400
401	}
402
403
404	=head2 _get_list
405
406	Get list C<Class::DBI> object.
407
408	my $list_obj = $nos->check_list('My list');
409
410	Returns false on failure.
411
412	=cut
413
414	sub _get_list {
415	my $self = shift;
416
417	my $name = shift \|\| return;
418
419	my $lists = $self->{'loader'}->find_class('lists') \|\| confess "can't find lists class";
420
421	return $lists->search({ name => $name })->first;
422	}
423
424
425	=head1 EXPORT
426
427	Nothing.
428
429	=head1 SEE ALSO
430
431	mailman, ezmlm, sympa, L<Mail::Salsa>
432
433
434	=head1 AUTHOR
435
436	Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
437
438
439	=head1 COPYRIGHT AND LICENSE
440
441	Copyright (C) 2005 by Dobrica Pavlinusic
442
443	This library is free software; you can redistribute it and/or modify
444	it under the same terms as Perl itself, either Perl version 5.8.4 or,
445	at your option, any later version of Perl 5 you may have available.
446
447
448	=cut