/[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 45 - (hide annotations)
Wed May 18 13:12:54 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 14259 byte(s)
added delete_member

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 45 our $VERSION = '0.4';
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 45 if ($name && $this_user->name ne $name) {
162     $this_user->name($name || '');
163 dpavlin 33 $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 dpavlin 45 List all members of some list.
181    
182 dpavlin 43 my @members = list_members(
183     list => 'My list',
184     );
185    
186     Returns array of hashes with user informations like this:
187    
188     $member = {
189 dpavlin 45 name => 'Dobrica Pavlinusic',
190 dpavlin 43 email => 'dpavlin@rot13.org
191     }
192    
193 dpavlin 45 If list is not found, returns false.
194    
195 dpavlin 43 =cut
196    
197     sub list_members {
198     my $self = shift;
199    
200     my $args = {@_};
201    
202     my $list_name = $args->{'list'} || confess "need list name";
203    
204     my $lists = $self->{'loader'}->find_class('lists');
205     my $user_list = $self->{'loader'}->find_class('user_list');
206    
207 dpavlin 45 my $this_list = $lists->search( name => $list_name )->first || return;
208 dpavlin 43
209     my @results;
210    
211     foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
212     my $row = {
213 dpavlin 45 name => $user_on_list->user_id->name,
214 dpavlin 43 email => $user_on_list->user_id->email,
215     };
216    
217     push @results, $row;
218     }
219    
220     return @results;
221    
222     }
223    
224    
225 dpavlin 45 =head2 delete_member
226    
227     Delete member from database.
228    
229     my $ok = delete_member(
230     name => 'Dobrica Pavlinusic'
231     );
232    
233     my $ok = delete_member(
234     email => 'dpavlin@rot13.org'
235     );
236    
237     Returns false if user doesn't exist.
238    
239     =cut
240    
241     sub delete_member {
242     my $self = shift;
243    
244     my $args = {@_};
245    
246     croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
247    
248     my $key = 'name';
249     $key = 'email' if ($args->{'email'});
250    
251     my $users = $self->{'loader'}->find_class('users');
252    
253     my $this_user = $users->search( $key => $args->{$key} )->first || return;
254    
255     print Dumper($this_user);
256    
257     $this_user->delete || croak "can't delete user\n";
258    
259     return $users->dbi_commit || croak "can't commit";
260     }
261    
262 dpavlin 29 =head2 add_message_to_list
263 dpavlin 24
264     Adds message to one list's queue for later sending.
265    
266 dpavlin 29 $nos->add_message_to_list(
267 dpavlin 24 list => 'My list',
268 dpavlin 36 message => 'Subject: welcome to list
269 dpavlin 38
270 dpavlin 24 This is example message
271     ',
272     );
273    
274     On success returns ID of newly created (or existing) message.
275    
276 dpavlin 36 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
277     will be automatically generated, but if you want to use own headers, just
278     include them in messages.
279    
280 dpavlin 24 =cut
281    
282 dpavlin 29 sub add_message_to_list {
283 dpavlin 24 my $self = shift;
284    
285     my $args = {@_};
286    
287     my $list_name = $args->{'list'} || confess "need list name";
288     my $message_text = $args->{'message'} || croak "need message";
289    
290 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
291    
292 dpavlin 32 unless( $m->header('Subject') ) {
293     warn "message doesn't have Subject header\n";
294     return;
295     }
296 dpavlin 29
297 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
298    
299     my $this_list = $lists->search(
300     name => $list_name,
301     )->first || croak "can't find list $list_name";
302    
303     my $messages = $self->{'loader'}->find_class('messages');
304    
305     my $this_message = $messages->find_or_create({
306     message => $message_text
307     }) || croak "can't insert message";
308    
309     $this_message->dbi_commit() || croak "can't add message";
310    
311     my $queue = $self->{'loader'}->find_class('queue');
312    
313     $queue->find_or_create({
314     message_id => $this_message->id,
315     list_id => $this_list->id,
316     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
317    
318     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
319    
320     return $this_message->id;
321     }
322    
323    
324 dpavlin 22 =head2 send_queued_messages
325 dpavlin 20
326 dpavlin 22 Send queued messages or just ones for selected list
327 dpavlin 20
328 dpavlin 24 $nos->send_queued_messages("My list");
329 dpavlin 20
330 dpavlin 21 =cut
331 dpavlin 20
332 dpavlin 22 sub send_queued_messages {
333 dpavlin 21 my $self = shift;
334 dpavlin 20
335 dpavlin 22 my $list_name = shift;
336 dpavlin 20
337 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
338     my $queue = $self->{'loader'}->find_class('queue');
339     my $user_list = $self->{'loader'}->find_class('user_list');
340     my $sent = $self->{'loader'}->find_class('sent');
341 dpavlin 20
342 dpavlin 22 my $my_q;
343     if ($list_name ne '') {
344     my $l_id = $lists->search_like( name => $list_name )->first ||
345     croak "can't find list $list_name";
346     $my_q = $queue->search_like( list_id => $l_id ) ||
347     croak "can't find list $list_name";
348     } else {
349     $my_q = $queue->retrieve_all;
350     }
351 dpavlin 20
352 dpavlin 22 while (my $m = $my_q->next) {
353     next if ($m->all_sent);
354 dpavlin 20
355 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
356     my $msg = $m->message_id->message;
357 dpavlin 20
358 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
359 dpavlin 20
360 dpavlin 29 my $to_email = $u->user_id->email;
361    
362 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
363    
364 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
365 dpavlin 29 print "SKIP $to_email message allready sent\n";
366 dpavlin 22 } else {
367 dpavlin 32 print "=> $to_email\n";
368 dpavlin 20
369 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
370 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
371 dpavlin 32
372 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
373 dpavlin 20
374 dpavlin 32 my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";
375 dpavlin 45 my $to = $u->user_id->name . " <$to_email>";
376 dpavlin 29
377 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
378 dpavlin 29
379 dpavlin 32 $m_obj->header_set('From', $from) || croak "can't set From: header";
380     $m_obj->header_set('To', $to) || croak "can't set To: header";
381 dpavlin 29
382 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
383     $m_obj->header_set('X-Nos-Hash', $hash);
384    
385 dpavlin 22 # FIXME do real sending :-)
386 dpavlin 32 send IO => $m_obj->as_string;
387 dpavlin 22
388     $sent->create({
389     message_id => $m->message_id,
390     user_id => $u->user_id,
391 dpavlin 36 hash => $hash,
392 dpavlin 22 });
393     $sent->dbi_commit;
394     }
395     }
396     $m->all_sent(1);
397     $m->update;
398     $m->dbi_commit;
399     }
400    
401 dpavlin 20 }
402    
403 dpavlin 29 =head2 inbox_message
404    
405     Receive single message for list's inbox.
406    
407 dpavlin 36 my $ok = $nos->inbox_message(
408     list => 'My list',
409     message => $message,
410     );
411 dpavlin 29
412     =cut
413    
414     sub inbox_message {
415     my $self = shift;
416    
417 dpavlin 36 my $arg = {@_};
418 dpavlin 29
419 dpavlin 36 return unless ($arg->{'message'});
420     croak "need list name" unless ($arg->{'list'});
421 dpavlin 29
422 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
423    
424 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
425    
426     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
427    
428     my @addrs = Email::Address->parse( $to );
429    
430     die "can't parse To: $to address\n" unless (@addrs);
431    
432     my $hl = $self->{'hash_len'} || confess "no hash_len?";
433    
434     my $hash;
435    
436     foreach my $a (@addrs) {
437     if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
438     $hash = $1;
439     last;
440     }
441     }
442    
443     croak "can't find hash in e-mail $to\n" unless ($hash);
444    
445     my $sent = $self->{'loader'}->find_class('sent');
446    
447     # will use null if no matching message_id is found
448 dpavlin 37 my $sent_msg = $sent->search( hash => $hash )->first;
449 dpavlin 36
450 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
451 dpavlin 36
452 dpavlin 37 if ($sent_msg) {
453     $message_id = $sent_msg->message_id || carp "no message_id";
454     $user_id = $sent_msg->user_id || carp "no user_id";
455     }
456    
457    
458     my $is_bounce = 0;
459    
460     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
461     $arg->{'message'}, { report_non_bounces=>1 },
462     ) };
463     carp "can't check if this message is bounce!" if ($@);
464    
465     $is_bounce++ if ($bounce && $bounce->is_bounce);
466    
467     my $received = $self->{'loader'}->find_class('received');
468    
469     my $this_received = $received->find_or_create({
470     user_id => $user_id,
471     list_id => $this_list->id,
472     message_id => $message_id,
473     message => $arg->{'message'},
474     bounced => $is_bounce,
475     }) || croak "can't insert received message";
476    
477     $this_received->dbi_commit;
478    
479 dpavlin 43 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
480    
481    
482 dpavlin 36 warn "inbox is not yet implemented";
483 dpavlin 29 }
484    
485    
486 dpavlin 30 =head1 INTERNAL METHODS
487    
488     Beware of dragons! You shouldn't need to call those methods directly.
489    
490     =head2 _add_list
491    
492     Create new list
493    
494     my $list_obj = $nos->_add_list(
495     list => 'My list',
496     email => 'my-list@example.com',
497     );
498    
499     Returns C<Class::DBI> object for created list.
500    
501 dpavlin 38 C<email> address can be with domain or without it if your
502     MTA appends it. There is no checking for validity of your
503     list e-mail. Flexibility comes with resposibility, so please
504     feed correct (and configured) return addresses.
505    
506 dpavlin 30 =cut
507    
508     sub _add_list {
509     my $self = shift;
510    
511     my $arg = {@_};
512    
513     my $name = $arg->{'list'} || confess "can't add list without name";
514     my $email = $arg->{'email'} || confess "can't add list without e-mail";
515    
516     my $lists = $self->{'loader'}->find_class('lists');
517    
518     my $l = $lists->find_or_create({
519     name => $name,
520     email => $email,
521     });
522    
523     croak "can't add list $name\n" unless ($l);
524    
525     $l->dbi_commit;
526    
527     return $l;
528    
529     }
530    
531    
532     =head2 _get_list
533    
534     Get list C<Class::DBI> object.
535    
536     my $list_obj = $nos->check_list('My list');
537    
538     Returns false on failure.
539    
540     =cut
541    
542     sub _get_list {
543     my $self = shift;
544    
545     my $name = shift || return;
546    
547 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
548 dpavlin 30
549 dpavlin 31 return $lists->search({ name => $name })->first;
550 dpavlin 30 }
551    
552 dpavlin 39 ###
553     ### SOAP
554     ###
555 dpavlin 30
556 dpavlin 39 package Nos::SOAP;
557    
558 dpavlin 43 use Carp;
559    
560 dpavlin 39 =head1 SOAP methods
561    
562     This methods are thin wrappers to provide SOAP calls. They are grouped in
563     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
564    
565     Usually, you want to use named variables in your SOAP calls if at all
566     possible.
567    
568     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
569     you will want to use positional arguments (in same order as documented for
570     methods below).
571    
572     =cut
573    
574     my $nos;
575    
576     sub new {
577     my $class = shift;
578     my $self = {@_};
579     bless($self, $class);
580    
581     $nos = new Nos( @_ ) || die "can't create Nos object";
582    
583     $self ? return $self : return undef;
584     }
585    
586    
587     =head2 NewList
588    
589     $message_id = NewList(
590     list => 'My list',
591     email => 'my-list@example.com'
592     );
593    
594     =cut
595    
596     sub NewList {
597     my $self = shift;
598    
599     if ($_[0] !~ m/^HASH/) {
600     return $nos->new_list(
601     list => $_[0], email => $_[1],
602     );
603     } else {
604     return $nos->new_list( %{ shift @_ } );
605     }
606     }
607    
608 dpavlin 43
609 dpavlin 39 =head2 AddMemberToList
610    
611     $member_id = AddMemberToList(
612 dpavlin 43 list => 'My list',
613     email => 'e-mail@example.com',
614     name => 'Full Name'
615 dpavlin 39 );
616    
617     =cut
618    
619     sub AddMemberToList {
620     my $self = shift;
621    
622     if ($_[0] !~ m/^HASH/) {
623     return $nos->add_member_to_list(
624     list => $_[0], email => $_[1], name => $_[2],
625     );
626     } else {
627     return $nos->add_member_to_list( %{ shift @_ } );
628     }
629     }
630    
631 dpavlin 43
632     =head2 ListMembers
633    
634     my @members = ListMembers(
635     list => 'My list',
636     );
637    
638     Returns array of hashes with user informations, see C<list_members>.
639    
640     =cut
641    
642     sub ListMembers {
643     my $self = shift;
644    
645     my $list_name;
646    
647     if ($_[0] !~ m/^HASH/) {
648     $list_name = shift;
649     } else {
650     $list_name = $_[0]->{'list'};
651     }
652    
653     return $nos->list_members( list => $list_name );
654     }
655    
656 dpavlin 39 =head2 AddMessageToList
657    
658     $message_id = AddMessageToList(
659     list => 'My list',
660     message => 'From: My list...'
661     );
662    
663     =cut
664    
665     sub AddMessageToList {
666     my $self = shift;
667    
668     if ($_[0] !~ m/^HASH/) {
669     return $nos->add_message_to_list(
670     list => $_[0], message => $_[1],
671     );
672     } else {
673     return $nos->add_message_to_list( %{ shift @_ } );
674     }
675     }
676    
677    
678     ###
679    
680 dpavlin 25 =head1 EXPORT
681 dpavlin 20
682 dpavlin 27 Nothing.
683 dpavlin 20
684     =head1 SEE ALSO
685    
686     mailman, ezmlm, sympa, L<Mail::Salsa>
687    
688 dpavlin 25
689 dpavlin 20 =head1 AUTHOR
690    
691     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
692    
693 dpavlin 25
694 dpavlin 20 =head1 COPYRIGHT AND LICENSE
695    
696     Copyright (C) 2005 by Dobrica Pavlinusic
697    
698     This library is free software; you can redistribute it and/or modify
699     it under the same terms as Perl itself, either Perl version 5.8.4 or,
700     at your option, any later version of Perl 5 you may have available.
701    
702    
703     =cut
704 dpavlin 39
705     1;

  ViewVC Help
Powered by ViewVC 1.1.26