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

Diff of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 21 by dpavlin, Sun May 15 21:35:15 2005 UTC revision 56 by dpavlin, Tue Jun 21 09:14:54 2005 UTC
# Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all' Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
16  our @EXPORT = qw(  our @EXPORT = qw(
17  );  );
18    
19  our $VERSION = '0.1';  our $VERSION = '0.5';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
23  use Email::Send;  use Email::Send;
24  use Carp;  use Carp;
25    use Email::Auth::AddressHash;
26    use Email::Simple;
27    use Email::Address;
28    use Mail::DeliveryStatus::BounceParser;
29    
30    
31  =head1 NAME  =head1 NAME
32    
# Line 48  Create new instance specifing database, Line 53  Create new instance specifing database,
53          passwd => '',          passwd => '',
54          debug => 1,          debug => 1,
55          verbose => 1,          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  =cut
63    
64  sub new {  sub new {
# Line 57  sub new { Line 66  sub new {
66          my $self = {@_};          my $self = {@_};
67          bless($self, $class);          bless($self, $class);
68    
69            croak "need at least dsn" unless ($self->{'dsn'});
70    
71          $self->{'loader'} = Class::DBI::Loader->new(          $self->{'loader'} = Class::DBI::Loader->new(
72                  debug           => $self->{'debug'},                  debug           => $self->{'debug'},
73                  dsn             => $self->{'dsn'},                  dsn             => $self->{'dsn'},
# Line 66  sub new { Line 77  sub new {
77  #               additional_classes      => qw/Class::DBI::AbstractSearch/,  #               additional_classes      => qw/Class::DBI::AbstractSearch/,
78  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
79                  relationships   => 1,                  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            from => 'Outgoing from comment',
96            email => 'my-list@example.com',
97     );
98    
99    Returns ID of newly created list.
100    
101    Calls internally L<_add_list>, see details there.
102    
103    =cut
104    
105    sub new_list {
106            my $self = shift;
107    
108            my $arg = {@_};
109    
110            confess "need list name" unless ($arg->{'list'});
111            confess "need list email" unless ($arg->{'email'});
112    
113            $arg->{'list'} = lc($arg->{'list'});
114            $arg->{'email'} = lc($arg->{'email'});
115    
116            my $l = $self->_get_list($arg->{'list'}) ||
117                    $self->_add_list( @_ ) ||
118                    return undef;
119    
120            return $l->id;
121    }
122    
123    
124    =head2 add_member_to_list
125    
126    Add new member to list
127    
128     $nos->add_member_to_list(
129            list => "My list",
130            email => "john.doe@example.com",
131            name => "John A. Doe",
132            ext_id => 42,
133     );
134    
135    C<name> and C<ext_id> parametars are optional.
136    
137    Return member ID if user is added.
138    
139    =cut
140    
141    sub add_member_to_list {
142            my $self = shift;
143    
144            my $arg = {@_};
145    
146            my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
147            my $name = $arg->{'name'} || '';
148            my $list_name = lc($arg->{'list'}) || croak "need list name";
149            my $ext_id = $arg->{'ext_id'};
150    
151            my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
152    
153            if (! Email::Valid->address($email)) {
154                    carp "SKIPPING $name <$email>\n";
155                    return 0;
156            }
157    
158            carp "# $name <$email>\n" if ($self->{'verbose'});
159    
160            my $users = $self->{'loader'}->find_class('users');
161            my $user_list = $self->{'loader'}->find_class('user_list');
162    
163            my $this_user = $users->find_or_create({
164                    email => $email,
165            }) || croak "can't find or create member\n";
166    
167            if ($name && $this_user->name ne $name) {
168                    $this_user->name($name || '');
169                    $this_user->update;
170            }
171    
172            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
173                    $this_user->ext_id($ext_id);
174                    $this_user->update;
175            }
176    
177            my $user_on_list = $user_list->find_or_create({
178                    user_id => $this_user->id,
179                    list_id => $list->id,
180            }) || croak "can't add user to list";
181    
182            $list->dbi_commit;
183            $this_user->dbi_commit;
184            $user_on_list->dbi_commit;
185    
186            return $this_user->id;
187    }
188    
189    =head2 list_members
190    
191    List all members of some list.
192    
193     my @members = list_members(
194            list => 'My list',
195     );
196    
197    Returns array of hashes with user informations like this:
198    
199     $member = {
200            name => 'Dobrica Pavlinusic',
201            email => 'dpavlin@rot13.org
202     }
203    
204    If list is not found, returns false. If there is C<ext_id> in user data,
205    that will also be returned.
206    
207    =cut
208    
209    sub list_members {
210            my $self = shift;
211    
212            my $args = {@_};
213    
214            my $list_name = lc($args->{'list'}) || confess "need list name";
215    
216            my $lists = $self->{'loader'}->find_class('lists');
217            my $user_list = $self->{'loader'}->find_class('user_list');
218    
219            my $this_list = $lists->search( name => $list_name )->first || return;
220    
221            my @results;
222    
223            foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
224                    my $row = {
225                            name => $user_on_list->user_id->name,
226                            email => $user_on_list->user_id->email,
227                    };
228    
229                    my $ext_id = $user_on_list->user_id->ext_id;
230                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
231    
232                    push @results, $row;
233            }
234    
235            return @results;
236    
237    }
238    
239    
240    =head2 delete_member
241    
242    Delete member from database.
243    
244     my $ok = delete_member(
245            name => 'Dobrica Pavlinusic'
246     );
247    
248     my $ok = delete_member(
249            email => 'dpavlin@rot13.org'
250     );
251    
252    Returns false if user doesn't exist.
253    
254    =cut
255    
256    sub delete_member {
257            my $self = shift;
258    
259            my $args = {@_};
260    
261            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
262    
263            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
264    
265            my $key = 'name';
266            $key = 'email' if ($args->{'email'});
267    
268            my $users = $self->{'loader'}->find_class('users');
269    
270            my $this_user = $users->search( $key => $args->{$key} )->first || return;
271    
272            $this_user->delete || croak "can't delete user\n";
273    
274            return $users->dbi_commit || croak "can't commit";
275    }
276    
277    =head2 add_message_to_list
278    
279    Adds message to one list's queue for later sending.
280    
281     $nos->add_message_to_list(
282            list => 'My list',
283            message => 'Subject: welcome to list
284    
285     This is example message
286     ',
287     );    
288    
289    On success returns ID of newly created (or existing) message.
290    
291    Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
292    will be automatically generated, but if you want to use own headers, just
293    include them in messages.
294    
295    =cut
296    
297    sub add_message_to_list {
298            my $self = shift;
299    
300            my $args = {@_};
301    
302            my $list_name = lc($args->{'list'}) || confess "need list name";
303            my $message_text = $args->{'message'} || croak "need message";
304    
305            my $m = Email::Simple->new($message_text) || croak "can't parse message";
306    
307            unless( $m->header('Subject') ) {
308                    warn "message doesn't have Subject header\n";
309                    return;
310            }
311    
312            my $lists = $self->{'loader'}->find_class('lists');
313    
314            my $this_list = $lists->search(
315                    name => $list_name,
316            )->first || croak "can't find list $list_name";
317    
318            my $messages = $self->{'loader'}->find_class('messages');
319    
320            my $this_message = $messages->find_or_create({
321                    message => $message_text
322            }) || croak "can't insert message";
323    
324            $this_message->dbi_commit() || croak "can't add message";
325    
326            my $queue = $self->{'loader'}->find_class('queue');
327    
328            $queue->find_or_create({
329                    message_id => $this_message->id,
330                    list_id => $this_list->id,
331            }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
332    
333            $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
334    
335            return $this_message->id;
336    }
337    
338    
339    =head2 send_queued_messages
340    
341    Send queued messages or just ones for selected list
342    
343     $nos->send_queued_messages(
344            list => 'My list',
345            driver => 'smtp',
346            sleep => 3,
347     );
348    
349    Second option is driver which will be used for e-mail delivery. If not
350    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
351    
352    Other valid drivers are:
353    
354    =over 10
355    
356    =item smtp
357    
358    Send e-mail using SMTP server at 127.0.0.1
359    
360    =back
361    
362    Default sleep wait between two messages is 3 seconds.
363    
364    =cut
365    
366    sub send_queued_messages {
367            my $self = shift;
368    
369            my $arg = {@_};
370    
371            my $list_name = lc($arg->{'list'}) || '';
372            my $driver = $arg->{'driver'} || '';
373            my $sleep = $arg->{'sleep'};
374            $sleep ||= 3 unless defined($sleep);
375    
376            my $email_send_driver = 'Email::Send::IO';
377            my @email_send_options;
378    
379            if (lc($driver) eq 'smtp') {
380                    $email_send_driver = 'Email::Send::SMTP';
381                    @email_send_options = ['127.0.0.1'];
382            } else {
383                    warn "dumping all messages to STDERR\n";
384            }
385    
386            my $lists = $self->{'loader'}->find_class('lists');
387            my $queue = $self->{'loader'}->find_class('queue');
388            my $user_list = $self->{'loader'}->find_class('user_list');
389            my $sent = $self->{'loader'}->find_class('sent');
390    
391            my $my_q;
392            if ($list_name ne '') {
393                    my $l_id = $lists->search_like( name => $list_name )->first ||
394                            croak "can't find list $list_name";
395                    $my_q = $queue->search_like( list_id => $l_id ) ||
396                            croak "can't find list $list_name";
397            } else {
398                    $my_q = $queue->retrieve_all;
399            }
400    
401            while (my $m = $my_q->next) {
402                    next if ($m->all_sent);
403    
404                    print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
405                    my $msg = $m->message_id->message;
406    
407                    foreach my $u ($user_list->search(list_id => $m->list_id)) {
408    
409                            my $to_email = $u->user_id->email;
410    
411                            my ($from,$domain) = split(/@/, $u->list_id->email, 2);
412    
413                            if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
414                                    print "SKIP $to_email message allready sent\n";
415                            } else {
416                                    print "=> $to_email\n";
417    
418                                    my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
419                                    my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
420    
421                                    my $hash = $auth->generate_hash( $to_email );
422    
423                                    my $from_addr;
424                                    my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
425    
426                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
427                                    $from_addr .= '<' . $from_email_only . '>';
428                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
429    
430                                    my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
431    
432                                    $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
433                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
434                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
435                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
436                                    $m_obj->header_set('To', $to) || croak "can't set To: header";
437    
438                                    $m_obj->header_set('X-Nos-Version', $VERSION);
439                                    $m_obj->header_set('X-Nos-Hash', $hash);
440    
441                                    # really send e-mail
442                                    if (@email_send_options) {
443                                            send $email_send_driver => $m_obj->as_string, @email_send_options;
444                                    } else {
445                                            send $email_send_driver => $m_obj->as_string;
446                                    }
447    
448                                    $sent->create({
449                                            message_id => $m->message_id,
450                                            user_id => $u->user_id,
451                                            hash => $hash,
452                                    });
453                                    $sent->dbi_commit;
454    
455                                    if ($sleep) {
456                                            warn "sleeping $sleep seconds\n";
457                                            sleep($sleep);
458                                    }
459                            }
460                    }
461                    $m->all_sent(1);
462                    $m->update;
463                    $m->dbi_commit;
464            }
465    
466    }
467    
468    =head2 inbox_message
469    
470    Receive single message for list's inbox.
471    
472     my $ok = $nos->inbox_message(
473            list => 'My list',
474            message => $message,
475     );
476    
477    =cut
478    
479    sub inbox_message {
480            my $self = shift;
481    
482            my $arg = {@_};
483    
484            return unless ($arg->{'message'});
485            croak "need list name" unless ($arg->{'list'});
486    
487            $arg->{'list'} = lc($arg->{'list'});
488    
489            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
490    
491            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
492    
493            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
494    
495            my $return_path = $m->header('Return-Path') || '';
496    
497            my @addrs = Email::Address->parse( $to );
498    
499            die "can't parse To: $to address\n" unless (@addrs);
500    
501            my $hl = $self->{'hash_len'} || confess "no hash_len?";
502    
503            my $hash;
504    
505            foreach my $a (@addrs) {
506                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
507                            $hash = $1;
508                            last;
509                    }
510            }
511    
512            #warn "can't find hash in e-mail $to\n" unless ($hash);
513    
514            my $sent = $self->{'loader'}->find_class('sent');
515    
516            # will use null if no matching message_id is found
517            my $sent_msg;
518            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
519    
520            my ($message_id, $user_id) = (undef, undef);    # init with NULL
521    
522            if ($sent_msg) {
523                    $message_id = $sent_msg->message_id || carp "no message_id";
524                    $user_id = $sent_msg->user_id || carp "no user_id";
525            } else {
526                    #warn "can't find sender with hash $hash\n";
527                    my $users = $self->{'loader'}->find_class('users');
528                    my $from = $m->header('From');
529                    $from = $1 if ($from =~ m/<(.*)>/);
530                    my $this_user = $users->search( email => lc($from) )->first;
531                    $user_id = $this_user->id if ($this_user);
532            }
533    
534    
535            my $is_bounce = 0;
536    
537            if ($return_path eq '<>' || $return_path eq '') {
538                    no warnings;
539                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
540                            $arg->{'message'}, { report_non_bounces=>1 },
541                    ) };
542                    #warn "can't check if this message is bounce!" if ($@);
543            
544                    $is_bounce++ if ($bounce && $bounce->is_bounce);
545            }
546    
547            my $received = $self->{'loader'}->find_class('received');
548    
549            my $this_received = $received->find_or_create({
550                    user_id => $user_id,
551                    list_id => $this_list->id,
552                    message_id => $message_id,
553                    message => $arg->{'message'},
554                    bounced => $is_bounce,
555            }) || croak "can't insert received message";
556    
557            $this_received->dbi_commit;
558    
559    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
560    }
561    
562    
563    =head1 INTERNAL METHODS
564    
565    Beware of dragons! You shouldn't need to call those methods directly.
566    
567    =head2 _add_list
568    
569    Create new list
570    
571     my $list_obj = $nos->_add_list(
572            list => 'My list',
573            from => 'Outgoing from comment',
574            email => 'my-list@example.com',
575     );
576    
577    Returns C<Class::DBI> object for created list.
578    
579    C<email> address can be with domain or without it if your
580    MTA appends it. There is no checking for validity of your
581    list e-mail. Flexibility comes with resposibility, so please
582    feed correct (and configured) return addresses.
583    
584    =cut
585    
586    sub _add_list {
587            my $self = shift;
588    
589            my $arg = {@_};
590    
591            my $name = lc($arg->{'list'}) || confess "can't add list without name";
592            my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
593            my $from_addr = $arg->{'from'};
594    
595            my $lists = $self->{'loader'}->find_class('lists');
596    
597            my $l = $lists->find_or_create({
598                    name => $name,
599                    email => $email,
600            });
601    
602            croak "can't add list $name\n" unless ($l);
603    
604            if ($from_addr && $l->from_addr ne $from_addr) {
605                    $l->from_addr($from_addr);
606                    $l->update;
607            }
608    
609            $l->dbi_commit;
610    
611            return $l;
612    
613    }
614    
615    
616    =head2 _get_list
617    
618    Get list C<Class::DBI> object.
619    
620     my $list_obj = $nos->check_list('My list');
621    
622    Returns false on failure.
623    
624    =cut
625    
626    sub _get_list {
627            my $self = shift;
628    
629            my $name = shift || return;
630    
631            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
632    
633            return $lists->search({ name => lc($name) })->first;
634    }
635    
636    ###
637    ### SOAP
638    ###
639    
640    package Nos::SOAP;
641    
642    use Carp;
643    
644    =head1 SOAP methods
645    
646    This methods are thin wrappers to provide SOAP calls. They are grouped in
647    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
648    
649    Usually, you want to use named variables in your SOAP calls if at all
650    possible.
651    
652    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
653    you will want to use positional arguments (in same order as documented for
654    methods below).
655    
656    =cut
657    
658    my $nos;
659    
660    sub new {
661            my $class = shift;
662            my $self = {@_};
663            bless($self, $class);
664    
665            $nos = new Nos( @_ ) || die "can't create Nos object";
666    
667          $self ? return $self : return undef;          $self ? return $self : return undef;
668  }  }
669    
 =head2 update_list_email  
670    
671  Update list e-mail address  =head2 NewList
672    
673   $noc->update_list_email($list, 'foobar@example.com');   $message_id = NewList(
674            list => 'My list',
675            from => 'Name of my list',
676            email => 'my-list@example.com'
677     );
678    
679  =cut  =cut
680    
681  sub update_list_email {  sub NewList {
682          my $self = shift;          my $self = shift;
683    
684            if ($_[0] !~ m/^HASH/) {
685                    return $nos->new_list(
686                            list => $_[0], from => $_[1], email => $_[2],
687                    );
688            } else {
689                    return $nos->new_list( %{ shift @_ } );
690            }
691    }
692    
693    
694    =head2 AddMemberToList
695    
696     $member_id = AddMemberToList(
697            list => 'My list',
698            email => 'e-mail@example.com',
699            name => 'Full Name'
700     );
701    
702    =cut
703    
704    sub AddMemberToList {
705            my $self = shift;
706    
707            if ($_[0] !~ m/^HASH/) {
708                    return $nos->add_member_to_list(
709                            list => $_[0], email => $_[1], name => $_[2],
710                    );
711            } else {
712                    return $nos->add_member_to_list( %{ shift @_ } );
713            }
714  }  }
715    
 =head2 send  
716    
717  Send a message using configured mailer.  =head2 ListMembers
718    
719     my @members = ListMembers(
720            list => 'My list',
721     );
722    
723   $nos->send("message with headers");  Returns array of hashes with user informations, see C<list_members>.
724    
725  =cut  =cut
726    
727  sub send_email {  sub ListMembers {
728          my $self = shift;          my $self = shift;
729    
730          my $message = shift || return;          my $list_name;
731    
732            if ($_[0] !~ m/^HASH/) {
733                    $list_name = shift;
734            } else {
735                    $list_name = $_[0]->{'list'};
736            }
737    
738          send IO => $message;          return $nos->list_members( list => $list_name );
739  }  }
740    
741  =head2 EXPORT  =head2 AddMessageToList
742    
743     $message_id = AddMessageToList(
744            list => 'My list',
745            message => 'From: My list...'
746     );
747    
748    =cut
749    
750    sub AddMessageToList {
751            my $self = shift;
752    
753  None by default.          if ($_[0] !~ m/^HASH/) {
754                    return $nos->add_message_to_list(
755                            list => $_[0], message => $_[1],
756                    );
757            } else {
758                    return $nos->add_message_to_list( %{ shift @_ } );
759            }
760    }
761    
762    
763    ###
764    
765    =head1 EXPORT
766    
767    Nothing.
768    
769  =head1 SEE ALSO  =head1 SEE ALSO
770    
771  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
772    
773    
774  =head1 AUTHOR  =head1 AUTHOR
775    
776  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
777    
778    
779  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
780    
781  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 123  at your option, any later version of Per Line 786  at your option, any later version of Per
786    
787    
788  =cut  =cut
789    
790    1;
Legend:
Removed from v.21  
changed lines
  Added in v.56
  ViewVC Help
Powered by ViewVC 1.1.26