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

  ViewVC Help
Powered by ViewVC 1.1.26