/[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 49 by dpavlin, Tue May 24 16:44:34 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 105  sub add_member_to_list { Line 146  sub add_member_to_list {
146          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";
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    
# Line 116  sub add_member_to_list { Line 157  sub add_member_to_list {
157    
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 131  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 194  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 236  sub send_queued_messages { Line 399  sub send_queued_messages {
399                                  print "=> $to_email\n";                                  print "=> $to_email\n";
400    
401                                  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;
402                                  my $auth = Email::Auth::AddressHash->new( $secret, 10 );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
403    
404                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
405    
406                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
407                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
408    
409                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
410                                    $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";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
414    
415                                  $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";
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";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
420    
421                                  # FIXME do real sending :-)                                  $m_obj->header_set('X-Nos-Version', $VERSION);
422                                  send IO => $m_obj->as_string;                                  $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 269  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          my $m = new Email::Simple->new($message);          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 = $sent->search( hash => $hash )->first;
499    
500            my ($message_id, $user_id) = (undef, undef);    # init with NULL
501    
502            if ($sent_msg) {
503                    $message_id = $sent_msg->message_id || carp "no message_id";
504                    $user_id = $sent_msg->user_id || carp "no user_id";
505            } else {
506                    warn "can't find sender with hash $hash\n";
507            }
508    
509    
510            my $is_bounce = 0;
511    
512            if ($return_path eq '<>' || $return_path eq '') {
513                    no warnings;
514                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
515                            $arg->{'message'}, { report_non_bounces=>1 },
516                    ) };
517                    warn "can't check if this message is bounce!" if ($@);
518            
519                    $is_bounce++ if ($bounce && $bounce->is_bounce);
520            }
521    
522            my $received = $self->{'loader'}->find_class('received');
523    
524            my $this_received = $received->find_or_create({
525                    user_id => $user_id,
526                    list_id => $this_list->id,
527                    message_id => $message_id,
528                    message => $arg->{'message'},
529                    bounced => $is_bounce,
530            }) || croak "can't insert received message";
531    
532            $this_received->dbi_commit;
533    
534    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
535  }  }
536    
537    
# Line 293  Create new list Line 545  Create new list
545    
546   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
547          list => 'My list',          list => 'My list',
548            from => 'Outgoing from comment',
549          email => 'my-list@example.com',          email => 'my-list@example.com',
550   );   );
551    
552  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
553    
554    C<email> address can be with domain or without it if your
555    MTA appends it. There is no checking for validity of your
556    list e-mail. Flexibility comes with resposibility, so please
557    feed correct (and configured) return addresses.
558    
559  =cut  =cut
560    
561  sub _add_list {  sub _add_list {
# Line 307  sub _add_list { Line 565  sub _add_list {
565    
566          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = $arg->{'list'} || confess "can't add list without name";
567          my $email = $arg->{'email'} || confess "can't add list without e-mail";          my $email = $arg->{'email'} || confess "can't add list without e-mail";
568            my $from_addr = $arg->{'from'};
569    
570          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
571    
# Line 314  sub _add_list { Line 573  sub _add_list {
573                  name => $name,                  name => $name,
574                  email => $email,                  email => $email,
575          });          });
576            
577          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
578    
579            if ($from_addr && $l->from_addr ne $from_addr) {
580                    $l->from_addr($from_addr);
581                    $l->update;
582            }
583    
584          $l->dbi_commit;          $l->dbi_commit;
585    
586          return $l;          return $l;
# Line 344  sub _get_list { Line 608  sub _get_list {
608          return $lists->search({ name => $name })->first;          return $lists->search({ name => $name })->first;
609  }  }
610    
611    ###
612    ### SOAP
613    ###
614    
615    package Nos::SOAP;
616    
617    use Carp;
618    
619    =head1 SOAP methods
620    
621    This methods are thin wrappers to provide SOAP calls. They are grouped in
622    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
623    
624    Usually, you want to use named variables in your SOAP calls if at all
625    possible.
626    
627    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
628    you will want to use positional arguments (in same order as documented for
629    methods below).
630    
631    =cut
632    
633    my $nos;
634    
635    sub new {
636            my $class = shift;
637            my $self = {@_};
638            bless($self, $class);
639    
640            $nos = new Nos( @_ ) || die "can't create Nos object";
641    
642            $self ? return $self : return undef;
643    }
644    
645    
646    =head2 NewList
647    
648     $message_id = NewList(
649            list => 'My list',
650            email => 'my-list@example.com'
651     );
652    
653    =cut
654    
655    sub NewList {
656            my $self = shift;
657    
658            if ($_[0] !~ m/^HASH/) {
659                    return $nos->new_list(
660                            list => $_[0], email => $_[1],
661                    );
662            } else {
663                    return $nos->new_list( %{ shift @_ } );
664            }
665    }
666    
667    
668    =head2 AddMemberToList
669    
670     $member_id = AddMemberToList(
671            list => 'My list',
672            email => 'e-mail@example.com',
673            name => 'Full Name'
674     );
675    
676    =cut
677    
678    sub AddMemberToList {
679            my $self = shift;
680    
681            if ($_[0] !~ m/^HASH/) {
682                    return $nos->add_member_to_list(
683                            list => $_[0], email => $_[1], name => $_[2],
684                    );
685            } else {
686                    return $nos->add_member_to_list( %{ shift @_ } );
687            }
688    }
689    
690    
691    =head2 ListMembers
692    
693     my @members = ListMembers(
694            list => 'My list',
695     );
696    
697    Returns array of hashes with user informations, see C<list_members>.
698    
699    =cut
700    
701    sub ListMembers {
702            my $self = shift;
703    
704            my $list_name;
705    
706            if ($_[0] !~ m/^HASH/) {
707                    $list_name = shift;
708            } else {
709                    $list_name = $_[0]->{'list'};
710            }
711    
712            return $nos->list_members( list => $list_name );
713    }
714    
715    =head2 AddMessageToList
716    
717     $message_id = AddMessageToList(
718            list => 'My list',
719            message => 'From: My list...'
720     );
721    
722    =cut
723    
724    sub AddMessageToList {
725            my $self = shift;
726    
727            if ($_[0] !~ m/^HASH/) {
728                    return $nos->add_message_to_list(
729                            list => $_[0], message => $_[1],
730                    );
731            } else {
732                    return $nos->add_message_to_list( %{ shift @_ } );
733            }
734    }
735    
736    
737    ###
738    
739  =head1 EXPORT  =head1 EXPORT
740    
# Line 369  at your option, any later version of Per Line 760  at your option, any later version of Per
760    
761    
762  =cut  =cut
763    
764    1;
Legend:
Removed from v.32  
changed lines
  Added in v.49
  ViewVC Help
Powered by ViewVC 1.1.26