/[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 38 - (hide annotations)
Tue May 17 21:37:06 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 10718 byte(s)
documentation and other misc improvements

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

  ViewVC Help
Powered by ViewVC 1.1.26