/[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 43 by dpavlin, Wed May 18 12:29:35 2005 UTC revision 60 by dpavlin, Tue Jun 21 21:24: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.5';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 26  use Email::Auth::AddressHash; Line 26  use Email::Auth::AddressHash;
26  use Email::Simple;  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
29  use Data::Dumper;  use Class::DBI::AbstractSearch;
30    
31    
32  =head1 NAME  =head1 NAME
33    
# Line 39  Nos - Notice Sender core module Line 40  Nos - Notice Sender core module
40    
41  =head1 DESCRIPTION  =head1 DESCRIPTION
42    
43  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
44    receive e-mails or send them directly to other hosts. It is not mail list
45    manager because it requires programming to add list members and send
46    messages. You can think of it as mechanisam for off-loading your e-mail
47    sending to remote server using SOAP service.
48    
49    It's concept is based around B<lists>. Each list can have zero or more
50    B<members>. Each list can have zero or more B<messages>.
51    
52    Here comes a twist: each outgoing message will have unique e-mail generated,
53    so Notice Sender will be able to link received replies (or bounces) with
54    outgoing messages.
55    
56    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
57    send attachments, handle 8-bit characters in headers (which have to be
58    encoded) or anything else.
59    
60    It will just queue your e-mail message to particular list (sending it to
61    possibly remote Notice Sender SOAP server just once), send it out at
62    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
63    track replies.
64    
65    It is best used to send smaller number of messages to more-or-less fixed
66    list of recipients while allowing individual responses to be examined.
67    Tipical use include replacing php e-mail sending code with SOAP call to
68    Notice Sender. It does support additional C<ext_id> field for each member
69    which can be used to track some unique identifier from remote system for
70    particular user.
71    
72    It comes with command-line utility C<sender.pl> which can be used to perform
73    all available operation from scripts (see C<perldoc sender.pl>).
74    This command is also useful for debugging while writing client SOAP
75    application.
76    
77  =head1 METHODS  =head1 METHODS
78    
# Line 74  sub new { Line 107  sub new {
107                  user            => $self->{'user'},                  user            => $self->{'user'},
108                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
109                  namespace       => "Nos",                  namespace       => "Nos",
110  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
111  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
112                  relationships   => 1,                  relationships   => 1,
113          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 92  C<email> address. Line 125  C<email> address.
125    
126   $nos->new_list(   $nos->new_list(
127          list => 'My list',          list => 'My list',
128            from => 'Outgoing from comment',
129          email => 'my-list@example.com',          email => 'my-list@example.com',
130   );   );
131    
132  Returns ID of newly created list.  Returns ID of newly created list.
133    
134  Calls internally L<_add_list>, see details there.  Calls internally C<_add_list>, see details there.
135    
136  =cut  =cut
137    
# Line 107  sub new_list { Line 141  sub new_list {
141          my $arg = {@_};          my $arg = {@_};
142    
143          confess "need list name" unless ($arg->{'list'});          confess "need list name" unless ($arg->{'list'});
144          confess "need list email" unless ($arg->{'list'});          confess "need list email" unless ($arg->{'email'});
145    
146            $arg->{'list'} = lc($arg->{'list'});
147            $arg->{'email'} = lc($arg->{'email'});
148    
149          my $l = $self->_get_list($arg->{'list'}) ||          my $l = $self->_get_list($arg->{'list'}) ||
150                  $self->_add_list( @_ ) ||                  $self->_add_list( @_ ) ||
# Line 125  Add new member to list Line 162  Add new member to list
162          list => "My list",          list => "My list",
163          email => "john.doe@example.com",          email => "john.doe@example.com",
164          name => "John A. Doe",          name => "John A. Doe",
165            ext_id => 42,
166   );   );
167    
168  C<name> parametar is optional.  C<name> and C<ext_id> parametars are optional.
169    
170  Return member ID if user is added.  Return member ID if user is added.
171    
# Line 138  sub add_member_to_list { Line 176  sub add_member_to_list {
176    
177          my $arg = {@_};          my $arg = {@_};
178    
179          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";
180          my $name = $arg->{'name'} || '';          my $name = $arg->{'name'} || '';
181          my $list_name = $arg->{'list'} || croak "need list name";          my $list_name = lc($arg->{'list'}) || croak "need list name";
182            my $ext_id = $arg->{'ext_id'};
183    
184          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";
185    
# Line 158  sub add_member_to_list { Line 197  sub add_member_to_list {
197                  email => $email,                  email => $email,
198          }) || croak "can't find or create member\n";          }) || croak "can't find or create member\n";
199    
200          if ($name && $this_user->full_name ne $name) {          if ($name && $this_user->name ne $name) {
201                  $this_user->full_name($name || '');                  $this_user->name($name || '');
202                    $this_user->update;
203            }
204    
205            if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
206                    $this_user->ext_id($ext_id);
207                  $this_user->update;                  $this_user->update;
208          }          }
209    
# Line 177  sub add_member_to_list { Line 221  sub add_member_to_list {
221    
222  =head2 list_members  =head2 list_members
223    
224    List all members of some list.
225    
226   my @members = list_members(   my @members = list_members(
227          list => 'My list',          list => 'My list',
228   );   );
# Line 184  sub add_member_to_list { Line 230  sub add_member_to_list {
230  Returns array of hashes with user informations like this:  Returns array of hashes with user informations like this:
231    
232   $member = {   $member = {
233          full_name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
234          email => 'dpavlin@rot13.org          email => 'dpavlin@rot13.org
235   }   }
236    
237    If list is not found, returns false. If there is C<ext_id> in user data,
238    it will also be returned.
239    
240  =cut  =cut
241    
242  sub list_members {  sub list_members {
# Line 195  sub list_members { Line 244  sub list_members {
244    
245          my $args = {@_};          my $args = {@_};
246    
247          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
248    
249          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
250          my $user_list = $self->{'loader'}->find_class('user_list');          my $user_list = $self->{'loader'}->find_class('user_list');
251    
252          my $this_list = $lists->search( name => $list_name )->first || croak "can't find list $list_name\n";          my $this_list = $lists->search( name => $list_name )->first || return;
253    
254          my @results;          my @results;
255    
256          foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {          foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
257                  my $row = {                  my $row = {
258                          full_name => $user_on_list->user_id->full_name,                          name => $user_on_list->user_id->name,
259                          email => $user_on_list->user_id->email,                          email => $user_on_list->user_id->email,
260                  };                  };
261    
262                    my $ext_id = $user_on_list->user_id->ext_id;
263                    $row->{'ext_id'} = $ext_id if (defined($ext_id));
264    
265                  push @results, $row;                  push @results, $row;
266          }          }
267    
# Line 218  sub list_members { Line 270  sub list_members {
270  }  }
271    
272    
273    =head2 delete_member
274    
275    Delete member from database.
276    
277     my $ok = delete_member(
278            name => 'Dobrica Pavlinusic'
279     );
280    
281     my $ok = delete_member(
282            email => 'dpavlin@rot13.org'
283     );
284    
285    Returns false if user doesn't exist.
286    
287    This function will delete member from all lists (by cascading delete), so it
288    shouldn't be used lightly.
289    
290    =cut
291    
292    sub delete_member {
293            my $self = shift;
294    
295            my $args = {@_};
296    
297            croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
298    
299            $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
300    
301            my $key = 'name';
302            $key = 'email' if ($args->{'email'});
303    
304            my $users = $self->{'loader'}->find_class('users');
305    
306            my $this_user = $users->search( $key => $args->{$key} )->first || return;
307    
308            $this_user->delete || croak "can't delete user\n";
309    
310            return $users->dbi_commit || croak "can't commit";
311    }
312    
313    =head2 delete_member_from_list
314    
315    Delete member from particular list.
316    
317     my $ok = delete_member_from_list(
318            list => 'My list',
319            email => 'dpavlin@rot13.org',
320     );
321    
322    Returns false if user doesn't exist on that particular list.
323    
324    It will die if list or user doesn't exist. You have been warned (you might
325    want to eval this functon to prevent it from croaking).
326    
327    =cut
328    
329    sub delete_member_from_list {
330            my $self = shift;
331    
332            my $args = {@_};
333    
334            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
335    
336            $args->{'list'} = lc($args->{'list'});
337            $args->{'email'} = lc($args->{'email'});
338    
339            my $user = $self->{'loader'}->find_class('users');
340            my $list = $self->{'loader'}->find_class('lists');
341            my $user_list = $self->{'loader'}->find_class('user_list');
342    
343            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
344            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
345    
346            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;
347    
348            $this_user_list->delete || croak "can't delete user from list\n";
349    
350            return $user_list->dbi_commit || croak "can't commit";
351    }
352    
353  =head2 add_message_to_list  =head2 add_message_to_list
354    
355  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 243  sub add_message_to_list { Line 375  sub add_message_to_list {
375    
376          my $args = {@_};          my $args = {@_};
377    
378          my $list_name = $args->{'list'} || confess "need list name";          my $list_name = lc($args->{'list'}) || confess "need list name";
379          my $message_text = $args->{'message'} || croak "need message";          my $message_text = $args->{'message'} || croak "need message";
380    
381          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 284  sub add_message_to_list { Line 416  sub add_message_to_list {
416    
417  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
418    
419   $nos->send_queued_messages("My list");   $nos->send_queued_messages(
420            list => 'My list',
421            driver => 'smtp',
422            sleep => 3,
423     );
424    
425    Second option is driver which will be used for e-mail delivery. If not
426    specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
427    
428    Other valid drivers are:
429    
430    =over 10
431    
432    =item smtp
433    
434    Send e-mail using SMTP server at 127.0.0.1
435    
436    =back
437    
438    Default sleep wait between two messages is 3 seconds.
439    
440  =cut  =cut
441    
442  sub send_queued_messages {  sub send_queued_messages {
443          my $self = shift;          my $self = shift;
444    
445          my $list_name = shift;          my $arg = {@_};
446    
447            my $list_name = lc($arg->{'list'}) || '';
448            my $driver = $arg->{'driver'} || '';
449            my $sleep = $arg->{'sleep'};
450            $sleep ||= 3 unless defined($sleep);
451    
452            my $email_send_driver = 'Email::Send::IO';
453            my @email_send_options;
454    
455            if (lc($driver) eq 'smtp') {
456                    $email_send_driver = 'Email::Send::SMTP';
457                    @email_send_options = ['127.0.0.1'];
458            } else {
459                    warn "dumping all messages to STDERR\n";
460            }
461    
462          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
463          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 330  sub send_queued_messages { Line 496  sub send_queued_messages {
496    
497                                  my $hash = $auth->generate_hash( $to_email );                                  my $hash = $auth->generate_hash( $to_email );
498    
499                                  my $from = $u->list_id->name . " <" . $from . "+" . $hash . ( $domain ? "@" . $domain : '' ). ">";                                  my $from_addr;
500                                  my $to = $u->user_id->full_name . " <$to_email>";                                  my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
501    
502                                    $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
503                                    $from_addr .= '<' . $from_email_only . '>';
504                                    my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
505    
506                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
507    
508                                  $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";
509                                    $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
510                                    $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
511                                    $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
512                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
513    
514                                  $m_obj->header_set('X-Nos-Version', $VERSION);                                  $m_obj->header_set('X-Nos-Version', $VERSION);
515                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
516    
517                                  # FIXME do real sending :-)                                  # really send e-mail
518                                  send IO => $m_obj->as_string;                                  if (@email_send_options) {
519                                            send $email_send_driver => $m_obj->as_string, @email_send_options;
520                                    } else {
521                                            send $email_send_driver => $m_obj->as_string;
522                                    }
523    
524                                  $sent->create({                                  $sent->create({
525                                          message_id => $m->message_id,                                          message_id => $m->message_id,
# Line 350  sub send_queued_messages { Line 527  sub send_queued_messages {
527                                          hash => $hash,                                          hash => $hash,
528                                  });                                  });
529                                  $sent->dbi_commit;                                  $sent->dbi_commit;
530    
531                                    if ($sleep) {
532                                            warn "sleeping $sleep seconds\n";
533                                            sleep($sleep);
534                                    }
535                          }                          }
536                  }                  }
537                  $m->all_sent(1);                  $m->all_sent(1);
# Line 368  Receive single message for list's inbox. Line 550  Receive single message for list's inbox.
550          message => $message,          message => $message,
551   );   );
552    
553    This method is used by C<sender.pl> when receiving e-mail messages.
554    
555  =cut  =cut
556    
557  sub inbox_message {  sub inbox_message {
# Line 378  sub inbox_message { Line 562  sub inbox_message {
562          return unless ($arg->{'message'});          return unless ($arg->{'message'});
563          croak "need list name" unless ($arg->{'list'});          croak "need list name" unless ($arg->{'list'});
564    
565            $arg->{'list'} = lc($arg->{'list'});
566    
567          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";          my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
568    
569          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";          my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
570    
571          my $to = $m->header('To') || die "can't find To: address in incomming message\n";          my $to = $m->header('To') || die "can't find To: address in incomming message\n";
572    
573            my $return_path = $m->header('Return-Path') || '';
574    
575          my @addrs = Email::Address->parse( $to );          my @addrs = Email::Address->parse( $to );
576    
577          die "can't parse To: $to address\n" unless (@addrs);          die "can't parse To: $to address\n" unless (@addrs);
# Line 393  sub inbox_message { Line 581  sub inbox_message {
581          my $hash;          my $hash;
582    
583          foreach my $a (@addrs) {          foreach my $a (@addrs) {
584                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {                  if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
585                          $hash = $1;                          $hash = $1;
586                          last;                          last;
587                  }                  }
588          }          }
589    
590          croak "can't find hash in e-mail $to\n" unless ($hash);          #warn "can't find hash in e-mail $to\n" unless ($hash);
591    
592          my $sent = $self->{'loader'}->find_class('sent');          my $sent = $self->{'loader'}->find_class('sent');
593    
594          # will use null if no matching message_id is found          # will use null if no matching message_id is found
595          my $sent_msg = $sent->search( hash => $hash )->first;          my $sent_msg;
596            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
597    
598          my ($message_id, $user_id) = (undef, undef);    # init with NULL          my ($message_id, $user_id) = (undef, undef);    # init with NULL
599    
600          if ($sent_msg) {          if ($sent_msg) {
601                  $message_id = $sent_msg->message_id || carp "no message_id";                  $message_id = $sent_msg->message_id || carp "no message_id";
602                  $user_id = $sent_msg->user_id || carp "no user_id";                  $user_id = $sent_msg->user_id || carp "no user_id";
603            } else {
604                    #warn "can't find sender with hash $hash\n";
605                    my $users = $self->{'loader'}->find_class('users');
606                    my $from = $m->header('From');
607                    $from = $1 if ($from =~ m/<(.*)>/);
608                    my $this_user = $users->search( email => lc($from) )->first;
609                    $user_id = $this_user->id if ($this_user);
610          }          }
611    
612    
613          my $is_bounce = 0;          my $is_bounce = 0;
614    
615          my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(          if ($return_path eq '<>' || $return_path eq '') {
616                  $arg->{'message'}, { report_non_bounces=>1 },                  no warnings;
617          ) };                  my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
618          carp "can't check if this message is bounce!" if ($@);                          $arg->{'message'}, { report_non_bounces=>1 },
619                    ) };
620          $is_bounce++ if ($bounce && $bounce->is_bounce);                  #warn "can't check if this message is bounce!" if ($@);
621            
622                    $is_bounce++ if ($bounce && $bounce->is_bounce);
623            }
624    
625          my $received = $self->{'loader'}->find_class('received');          my $received = $self->{'loader'}->find_class('received');
626    
# Line 435  sub inbox_message { Line 634  sub inbox_message {
634    
635          $this_received->dbi_commit;          $this_received->dbi_commit;
636    
637          print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
   
   
         warn "inbox is not yet implemented";  
638  }  }
639    
640    
# Line 452  Create new list Line 648  Create new list
648    
649   my $list_obj = $nos->_add_list(   my $list_obj = $nos->_add_list(
650          list => 'My list',          list => 'My list',
651            from => 'Outgoing from comment',
652          email => 'my-list@example.com',          email => 'my-list@example.com',
653   );   );
654    
# Line 469  sub _add_list { Line 666  sub _add_list {
666    
667          my $arg = {@_};          my $arg = {@_};
668    
669          my $name = $arg->{'list'} || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
670          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";
671            my $from_addr = $arg->{'from'};
672    
673          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
674    
# Line 478  sub _add_list { Line 676  sub _add_list {
676                  name => $name,                  name => $name,
677                  email => $email,                  email => $email,
678          });          });
679            
680          croak "can't add list $name\n" unless ($l);          croak "can't add list $name\n" unless ($l);
681    
682            if ($from_addr && $l->from_addr ne $from_addr) {
683                    $l->from_addr($from_addr);
684                    $l->update;
685            }
686    
687          $l->dbi_commit;          $l->dbi_commit;
688    
689          return $l;          return $l;
# Line 505  sub _get_list { Line 708  sub _get_list {
708    
709          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";
710    
711          return $lists->search({ name => $name })->first;          return $lists->search({ name => lc($name) })->first;
712  }  }
713    
714  ###  ###
# Line 547  sub new { Line 750  sub new {
750    
751   $message_id = NewList(   $message_id = NewList(
752          list => 'My list',          list => 'My list',
753            from => 'Name of my list',
754          email => 'my-list@example.com'          email => 'my-list@example.com'
755   );   );
756    
# Line 557  sub NewList { Line 761  sub NewList {
761    
762          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
763                  return $nos->new_list(                  return $nos->new_list(
764                          list => $_[0], email => $_[1],                          list => $_[0], from => $_[1], email => $_[2],
765                  );                  );
766          } else {          } else {
767                  return $nos->new_list( %{ shift @_ } );                  return $nos->new_list( %{ shift @_ } );
# Line 570  sub NewList { Line 774  sub NewList {
774   $member_id = AddMemberToList(   $member_id = AddMemberToList(
775          list => 'My list',          list => 'My list',
776          email => 'e-mail@example.com',          email => 'e-mail@example.com',
777          name => 'Full Name'          name => 'Full Name',
778            ext_id => 42,
779   );   );
780    
781  =cut  =cut
# Line 580  sub AddMemberToList { Line 785  sub AddMemberToList {
785    
786          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
787                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
788                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
789                  );                  );
790          } else {          } else {
791                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
Legend:
Removed from v.43  
changed lines
  Added in v.60
  ViewVC Help
Powered by ViewVC 1.1.26