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