/[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 29 by dpavlin, Mon May 16 20:58:44 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.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 84  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 97  sub add_member_to_list { Line 143  sub add_member_to_list {
143    
144          my $arg = {@_};          my $arg = {@_};
145    
146          my $email = $arg->{'email'} || confess "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          confess "need list name" unless ($arg->{'list'});          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)) {          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    
158          carp "# $name <$email>\n" if ($self->{'verbose'});          carp "# $name <$email>\n" if ($self->{'verbose'});
159    
         my $lists = $self->{'loader'}->find_class('lists');  
160          my $users = $self->{'loader'}->find_class('users');          my $users = $self->{'loader'}->find_class('users');
161          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
162    
         my $list = $lists->find_or_create({  
                 name => $arg->{'list'},  
         }) || croak "can't add list ",$arg->{'list'},"\n";  
           
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 133  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 155  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    
         warn Dumper($message_text);  
   
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";
306    
307          croak "message doesn't have Subject header\n" unless( $m->header('Subject') );          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');          my $lists = $self->{'loader'}->find_class('lists');
313    
# Line 195  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 225  sub send_queued_messages { Line 404  sub send_queued_messages {
404                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
405                  my $msg = $m->message_id->message;                  my $msg = $m->message_id->message;
406    
                 my $auth = Email::Auth::AddressHash->new(  
                         $m->list_id->name,      # secret  
                         10,                     # hashlen  
                 );  
   
407                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
408    
409                          my $to_email = $u->user_id->email;                          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 )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
414                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
415                          } else {                          } else {
416                                  print "\t$to_email\n";                                  print "=> $to_email\n";
   
                                 my $hash = $auth->generate_hash( $to_email );  
   
                                 my $from = $u->list_id->name . " <" . $u->list_id->email . "+" . $hash . ">";  
                                 my $to = $u->user_id->full_name . " <$to_email>";  
417    
418                                  my $m = Email::Simple->new($msg) || croak "can't parse message";                                  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                                  print Dumper($m);                                  my $hash = $auth->generate_hash( $to_email );
422    
423                                  $m->header_set('From', $from) || croak "can't set From: header";                                  my $from_addr;
424                                  $m->header_set('To', $to) || croak "can't set To: header";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
425    
426                                  # FIXME do real sending :-)                                  $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
427                                  send IO => $m->as_string;                                  $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({                                  $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 272  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 = 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;
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     );
701    
702    =cut
703    
704          my $m = new Email::Simple->new($message);  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    
716    
717    =head2 ListMembers
718    
719     my @members = ListMembers(
720            list => 'My list',
721     );
722    
723    Returns array of hashes with user informations, see C<list_members>.
724    
725    =cut
726    
727    sub ListMembers {
728            my $self = shift;
729    
730            my $list_name;
731    
732            if ($_[0] !~ m/^HASH/) {
733                    $list_name = shift;
734            } else {
735                    $list_name = $_[0]->{'list'};
736            }
737    
738            return $nos->list_members( list => $list_name );
739    }
740    
741    =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            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  =head1 EXPORT
766    
767  Nothing.  Nothing.
# Line 310  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.29  
changed lines
  Added in v.56
  ViewVC Help
Powered by ViewVC 1.1.26