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