/[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 43 - (show annotations)
Wed May 18 12:29:35 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 13555 byte(s)
added list_members

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 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 =head2 add_message_to_list
222
223 Adds message to one list's queue for later sending.
224
225 $nos->add_message_to_list(
226 list => 'My list',
227 message => 'Subject: welcome to list
228
229 This is example message
230 ',
231 );
232
233 On success returns ID of newly created (or existing) message.
234
235 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 =cut
240
241 sub add_message_to_list {
242 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 my $m = Email::Simple->new($message_text) || croak "can't parse message";
250
251 unless( $m->header('Subject') ) {
252 warn "message doesn't have Subject header\n";
253 return;
254 }
255
256 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 =head2 send_queued_messages
284
285 Send queued messages or just ones for selected list
286
287 $nos->send_queued_messages("My list");
288
289 =cut
290
291 sub send_queued_messages {
292 my $self = shift;
293
294 my $list_name = shift;
295
296 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
301 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
311 while (my $m = $my_q->next) {
312 next if ($m->all_sent);
313
314 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
317 foreach my $u ($user_list->search(list_id => $m->list_id)) {
318
319 my $to_email = $u->user_id->email;
320
321 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
322
323 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
324 print "SKIP $to_email message allready sent\n";
325 } else {
326 print "=> $to_email\n";
327
328 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
329 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
330
331 my $hash = $auth->generate_hash( $to_email );
332
333 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
334 my $to = $u->user_id->full_name . " <$to_email>";
335
336 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
337
338 $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
341 $m_obj->header_set('X-Nos-Version', $VERSION);
342 $m_obj->header_set('X-Nos-Hash', $hash);
343
344 # FIXME do real sending :-)
345 send IO => $m_obj->as_string;
346
347 $sent->create({
348 message_id => $m->message_id,
349 user_id => $u->user_id,
350 hash => $hash,
351 });
352 $sent->dbi_commit;
353 }
354 }
355 $m->all_sent(1);
356 $m->update;
357 $m->dbi_commit;
358 }
359
360 }
361
362 =head2 inbox_message
363
364 Receive single message for list's inbox.
365
366 my $ok = $nos->inbox_message(
367 list => 'My list',
368 message => $message,
369 );
370
371 =cut
372
373 sub inbox_message {
374 my $self = shift;
375
376 my $arg = {@_};
377
378 return unless ($arg->{'message'});
379 croak "need list name" unless ($arg->{'list'});
380
381 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
382
383 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 my $sent_msg = $sent->search( hash => $hash )->first;
408
409 my ($message_id, $user_id) = (undef, undef); # init with NULL
410
411 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 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
439
440
441 warn "inbox is not yet implemented";
442 }
443
444
445 =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 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 =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 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
507
508 return $lists->search({ name => $name })->first;
509 }
510
511 ###
512 ### SOAP
513 ###
514
515 package Nos::SOAP;
516
517 use Carp;
518
519 =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
568 =head2 AddMemberToList
569
570 $member_id = AddMemberToList(
571 list => 'My list',
572 email => 'e-mail@example.com',
573 name => 'Full Name'
574 );
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
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 =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 =head1 EXPORT
640
641 Nothing.
642
643 =head1 SEE ALSO
644
645 mailman, ezmlm, sympa, L<Mail::Salsa>
646
647
648 =head1 AUTHOR
649
650 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
651
652
653 =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
664 1;

  ViewVC Help
Powered by ViewVC 1.1.26