/[notice-sender]/trunk/Nos.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 37 - (hide annotations)
Tue May 17 19:15:27 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 10228 byte(s)
check for bounces

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

  ViewVC Help
Powered by ViewVC 1.1.26