/[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

Contents of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 38 - (show annotations)
Tue May 17 21:37:06 2005 UTC (18 years, 10 months ago) by dpavlin
File size: 10718 byte(s)
documentation and other misc improvements

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 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->full_name ne $name) {
162 $this_user->full_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 add_message_to_list
179
180 Adds message to one list's queue for later sending.
181
182 $nos->add_message_to_list(
183 list => 'My list',
184 message => 'Subject: welcome to list
185
186 This is example message
187 ',
188 );
189
190 On success returns ID of newly created (or existing) message.
191
192 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 =cut
197
198 sub add_message_to_list {
199 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 my $m = Email::Simple->new($message_text) || croak "can't parse message";
207
208 unless( $m->header('Subject') ) {
209 warn "message doesn't have Subject header\n";
210 return;
211 }
212
213 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 =head2 send_queued_messages
241
242 Send queued messages or just ones for selected list
243
244 $nos->send_queued_messages("My list");
245
246 =cut
247
248 sub send_queued_messages {
249 my $self = shift;
250
251 my $list_name = shift;
252
253 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
258 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
268 while (my $m = $my_q->next) {
269 next if ($m->all_sent);
270
271 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
274 foreach my $u ($user_list->search(list_id => $m->list_id)) {
275
276 my $to_email = $u->user_id->email;
277
278 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
279
280 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
281 print "SKIP $to_email message allready sent\n";
282 } else {
283 print "=> $to_email\n";
284
285 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
286 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
287
288 my $hash = $auth->generate_hash( $to_email );
289
290 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
291 my $to = $u->user_id->full_name . " <$to_email>";
292
293 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
294
295 $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
298 $m_obj->header_set('X-Nos-Version', $VERSION);
299 $m_obj->header_set('X-Nos-Hash', $hash);
300
301 # FIXME do real sending :-)
302 send IO => $m_obj->as_string;
303
304 $sent->create({
305 message_id => $m->message_id,
306 user_id => $u->user_id,
307 hash => $hash,
308 });
309 $sent->dbi_commit;
310 }
311 }
312 $m->all_sent(1);
313 $m->update;
314 $m->dbi_commit;
315 }
316
317 }
318
319 =head2 inbox_message
320
321 Receive single message for list's inbox.
322
323 my $ok = $nos->inbox_message(
324 list => 'My list',
325 message => $message,
326 );
327
328 =cut
329
330 sub inbox_message {
331 my $self = shift;
332
333 my $arg = {@_};
334
335 return unless ($arg->{'message'});
336 croak "need list name" unless ($arg->{'list'});
337
338 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
339
340 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 my $sent_msg = $sent->search( hash => $hash )->first;
365
366 my ($message_id, $user_id) = (undef, undef); # init with NULL
367
368 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 warn "inbox is not yet implemented";
397 }
398
399
400 =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 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 =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 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
462
463 return $lists->search({ name => $name })->first;
464 }
465
466
467 =head1 EXPORT
468
469 Nothing.
470
471 =head1 SEE ALSO
472
473 mailman, ezmlm, sympa, L<Mail::Salsa>
474
475
476 =head1 AUTHOR
477
478 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
479
480
481 =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