/[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 32 by dpavlin, Mon May 16 22:32:58 2005 UTC revision 58 by dpavlin, Tue Jun 21 09:41:43 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.3';  our $VERSION = '0.5';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 24  use Email::Send; Line 24  use Email::Send;
24  use Carp;  use Carp;
25  use Email::Auth::AddressHash;  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Data::Dumper;  use Email::Address;
28    use Mail::DeliveryStatus::BounceParser;
29    
30    
31  =head1 NAME  =head1 NAME
32    
# Line 51  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 73  sub new { Line 79  sub new {
79                  relationships   => 1,                  relationships   => 1,
80          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
81    
82            $self->{'hash_len'} ||= 8;
83    
84          $self ? return $self : return undef;          $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  =head2 add_member_to_list
125    
126  Add new member to list  Add new member to list
# Line 85  Add new member to list Line 129  Add new member to list
129          list => "My list",          list => "My list",
130          email => "john.doe@example.com",          email => "john.doe@example.com",
131          name => "John A. Doe",          name => "John A. Doe",
132            ext_id => 42,
133   );   );
134    
135  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
136    
137  Return member ID if user is added.  Return member ID if user is added.
138    
# Line 98  sub add_member_to_list { Line 143  sub add_member_to_list {
143    
144          my $arg = {@_};          my $arg = {@_};
145    
146          my $email = $arg->{'email'} || croak "can't add user without e-mail";          my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
147          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
148          my $list_name = $arg->{'list'} || croak "need list name";          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";          my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
152    
153          if (! Email::Valid->address($email)) {          if (! Email::Valid->address($email)) {
154                  carp "SKIPPING $name <$email>\n" if ($self->{'verbose'});                  carp "SKIPPING $name <$email>\n";
155                  return 0;                  return 0;
156          }          }
157    
# Line 116  sub add_member_to_list { Line 162  sub add_member_to_list {
162    
163          my $this_user = $users->find_or_create({          my $this_user = $users->find_or_create({
164                  email => $email,                  email => $email,
                 full_name => $name,  
165          }) || croak "can't find or create member\n";          }) || 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({          my $user_on_list = $user_list->find_or_create({
178                  user_id => $this_user->id,                  user_id => $this_user->id,
179                  list_id => $list->id,                  list_id => $list->id,
# Line 131  sub add_member_to_list { Line 186  sub add_member_to_list {
186          return $this_user->id;          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  =head2 add_message_to_list
278    
279  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
280    
281   $nos->add_message_to_list(   $nos->add_message_to_list(
282          list => 'My list',          list => 'My list',
283          message => 'From: My list <mylist@example.com>          message => 'Subject: welcome to list
284   To: John A. Doe <john.doe@example.com>  
   
285   This is example message   This is example message
286   ',   ',
287   );       );    
288    
289  On success returns ID of newly created (or existing) message.  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  =cut
296    
297  sub add_message_to_list {  sub add_message_to_list {
# Line 153  sub add_message_to_list { Line 299  sub add_message_to_list {
299    
300          my $args = {@_};          my $args = {@_};
301    
302          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
303          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
304    
305          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
# Line 194  sub add_message_to_list { Line 340  sub add_message_to_list {
340    
341  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
342    
343   $nos->send_queued_messages("My list");   $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  =cut
365    
366  sub send_queued_messages {  sub send_queued_messages {
367          my $self = shift;          my $self = shift;
368    
369          my $list_name = shift;          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');          my $lists = $self->{'loader'}->find_class('lists');
387          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 236  sub send_queued_messages { Line 416  sub send_queued_messages {
416                                  print "=> $to_email\n";                                  print "=> $to_email\n";
417    
418                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
419                                  my $auth = Email::Auth::AddressHash->new( $secret, 10 );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
420    
421                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
422    
423                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
424                                  my $to = $u->user_id->full_name . " <$to_email>";                                  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";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
431    
432                                  $m_obj->header_set('From', $from) || croak "can't set From: header";                                  $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";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
437    
438                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
439                                  send IO => $m_obj->as_string;                                  $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({                                  $sent->create({
449                                          message_id => $m->message_id,                                          message_id => $m->message_id,
450                                          user_id => $u->user_id,                                          user_id => $u->user_id,
451                                            hash => $hash,
452                                  });                                  });
453                                  $sent->dbi_commit;                                  $sent->dbi_commit;
454    
455                                    if ($sleep) {
456                                            warn "sleeping $sleep seconds\n";
457                                            sleep($sleep);
458                                    }
459                          }                          }
460                  }                  }
461                  $m->all_sent(1);                  $m->all_sent(1);
# Line 269  sub send_queued_messages { Line 469  sub send_queued_messages {
469    
470  Receive single message for list's inbox.  Receive single message for list's inbox.
471    
472   my $ok = $nos->inbox_message($message);   my $ok = $nos->inbox_message(
473            list => 'My list',
474            message => $message,
475     );
476    
477  =cut  =cut
478    
479  sub inbox_message {  sub inbox_message {
480          my $self = shift;          my $self = shift;
481    
482          my $message = shift || return;          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 = new Email::Simple->new($message);          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    
# Line 293  Create new list Line 570  Create new list
570    
571   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
572          list => 'My list',          list => 'My list',
573            from => 'Outgoing from comment',
574          email => 'my-list@example.com',          email => 'my-list@example.com',
575   );   );
576    
577  Returns C<Class::DBI> object for created list.  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  =cut
585    
586  sub _add_list {  sub _add_list {
# Line 305  sub _add_list { Line 588  sub _add_list {
588    
589          my $arg = {@_};          my $arg = {@_};
590    
591          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
592          my $email = $arg->{'email'} || confess "can't add list without e-mail";          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');          my $lists = $self->{'loader'}->find_class('lists');
596    
# Line 314  sub _add_list { Line 598  sub _add_list {
598                  name => $name,                  name => $name,
599                  email => $email,                  email => $email,
600          });          });
601            
602          croak "can't add list $name\n" unless ($l);          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;          $l->dbi_commit;
610    
611          return $l;          return $l;
# Line 341  sub _get_list { Line 630  sub _get_list {
630    
631          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";          my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
632    
633          return $lists->search({ name => $name })->first;          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;
668    }
669    
670    
671    =head2 NewList
672    
673     $message_id = NewList(
674            list => 'My list',
675            from => 'Name of my list',
676            email => 'my-list@example.com'
677     );
678    
679    =cut
680    
681    sub NewList {
682            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            ext_id => 42,
701     );
702    
703    =cut
704    
705    sub AddMemberToList {
706            my $self = shift;
707    
708            if ($_[0] !~ m/^HASH/) {
709                    return $nos->add_member_to_list(
710                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
711                    );
712            } else {
713                    return $nos->add_member_to_list( %{ shift @_ } );
714            }
715    }
716    
717    
718    =head2 ListMembers
719    
720     my @members = ListMembers(
721            list => 'My list',
722     );
723    
724    Returns array of hashes with user informations, see C<list_members>.
725    
726    =cut
727    
728    sub ListMembers {
729            my $self = shift;
730    
731            my $list_name;
732    
733            if ($_[0] !~ m/^HASH/) {
734                    $list_name = shift;
735            } else {
736                    $list_name = $_[0]->{'list'};
737            }
738    
739            return $nos->list_members( list => $list_name );
740  }  }
741    
742    =head2 AddMessageToList
743    
744     $message_id = AddMessageToList(
745            list => 'My list',
746            message => 'From: My list...'
747     );
748    
749    =cut
750    
751    sub AddMessageToList {
752            my $self = shift;
753    
754            if ($_[0] !~ m/^HASH/) {
755                    return $nos->add_message_to_list(
756                            list => $_[0], message => $_[1],
757                    );
758            } else {
759                    return $nos->add_message_to_list( %{ shift @_ } );
760            }
761    }
762    
763    
764    ###
765    
766  =head1 EXPORT  =head1 EXPORT
767    
# Line 369  at your option, any later version of Per Line 787  at your option, any later version of Per
787    
788    
789  =cut  =cut
790    
791    1;
Legend:
Removed from v.32  
changed lines
  Added in v.58
  ViewVC Help
Powered by ViewVC 1.1.26