/[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 56 by dpavlin, Tue Jun 21 09:14:54 2005 UTC revision 66 by dpavlin, Fri Jul 8 11:46:35 2005 UTC
# 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 Class::DBI::AbstractSearch;
30    use Mail::Alias;
31    use Cwd qw(abs_path);
32    
33    
34  =head1 NAME  =head1 NAME
# Line 39  Nos - Notice Sender core module Line 42  Nos - Notice Sender core module
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
44    
45  Core module for notice sender's functionality.  Notice sender is mail handler. It is not MTA, since it doesn't know how to
46    receive e-mails or send them directly to other hosts. It is not mail list
47    manager because it requires programming to add list members and send
48    messages. You can think of it as mechanisam for off-loading your e-mail
49    sending to remote server using SOAP service.
50    
51    It's concept is based around B<lists>. Each list can have zero or more
52    B<members>. Each list can have zero or more B<messages>.
53    
54    Here comes a twist: each outgoing message will have unique e-mail generated,
55    so Notice Sender will be able to link received replies (or bounces) with
56    outgoing messages.
57    
58    It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
59    send attachments, handle 8-bit characters in headers (which have to be
60    encoded) or anything else.
61    
62    It will just queue your e-mail message to particular list (sending it to
63    possibly remote Notice Sender SOAP server just once), send it out at
64    reasonable rate (so that it doesn't flood your e-mail infrastructure) and
65    track replies.
66    
67    It is best used to send smaller number of messages to more-or-less fixed
68    list of recipients while allowing individual responses to be examined.
69    Tipical use include replacing php e-mail sending code with SOAP call to
70    Notice Sender. It does support additional C<ext_id> field for each member
71    which can be used to track some unique identifier from remote system for
72    particular user.
73    
74    It comes with command-line utility C<sender.pl> which can be used to perform
75    all available operation from scripts (see C<perldoc sender.pl>).
76    This command is also useful for debugging while writing client SOAP
77    application.
78    
79  =head1 METHODS  =head1 METHODS
80    
# Line 74  sub new { Line 109  sub new {
109                  user            => $self->{'user'},                  user            => $self->{'user'},
110                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
111                  namespace       => "Nos",                  namespace       => "Nos",
112  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
113  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
114                  relationships   => 1,                  relationships   => 1,
115          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
# Line 98  C<email> address. Line 133  C<email> address.
133    
134  Returns ID of newly created list.  Returns ID of newly created list.
135    
136  Calls internally L<_add_list>, see details there.  Calls internally C<_add_list>, see details there.
137    
138  =cut  =cut
139    
# Line 121  sub new_list { Line 156  sub new_list {
156  }  }
157    
158    
159    =head2 delete_list
160    
161    Delete list from database.
162    
163     my $ok = delete_list(
164            list => 'My list'
165     );
166    
167    Returns false if list doesn't exist.
168    
169    =cut
170    
171    sub delete_list {
172            my $self = shift;
173    
174            my $args = {@_};
175    
176            croak "need list to delete" unless ($args->{'list'});
177    
178            $args->{'list'} = lc($args->{'list'});
179    
180            my $lists = $self->{'loader'}->find_class('lists');
181    
182            my $this_list = $lists->search( name => $args->{'list'} )->first || return;
183    
184            $this_list->delete || croak "can't delete list\n";
185    
186            return $lists->dbi_commit || croak "can't commit";
187    }
188    
189    
190  =head2 add_member_to_list  =head2 add_member_to_list
191    
192  Add new member to list  Add new member to list
# Line 202  Returns array of hashes with user inform Line 268  Returns array of hashes with user inform
268   }   }
269    
270  If list is not found, returns false. If there is C<ext_id> in user data,  If list is not found, returns false. If there is C<ext_id> in user data,
271  that will also be returned.  it will also be returned.
272    
273  =cut  =cut
274    
# Line 251  Delete member from database. Line 317  Delete member from database.
317    
318  Returns false if user doesn't exist.  Returns false if user doesn't exist.
319    
320    This function will delete member from all lists (by cascading delete), so it
321    shouldn't be used lightly.
322    
323  =cut  =cut
324    
325  sub delete_member {  sub delete_member {
# Line 274  sub delete_member { Line 343  sub delete_member {
343          return $users->dbi_commit || croak "can't commit";          return $users->dbi_commit || croak "can't commit";
344  }  }
345    
346    =head2 delete_member_from_list
347    
348    Delete member from particular list.
349    
350     my $ok = delete_member_from_list(
351            list => 'My list',
352            email => 'dpavlin@rot13.org',
353     );
354    
355    Returns false if user doesn't exist on that particular list.
356    
357    It will die if list or user doesn't exist. You have been warned (you might
358    want to eval this functon to prevent it from croaking).
359    
360    =cut
361    
362    sub delete_member_from_list {
363            my $self = shift;
364    
365            my $args = {@_};
366    
367            croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
368    
369            $args->{'list'} = lc($args->{'list'});
370            $args->{'email'} = lc($args->{'email'});
371    
372            my $user = $self->{'loader'}->find_class('users');
373            my $list = $self->{'loader'}->find_class('lists');
374            my $user_list = $self->{'loader'}->find_class('user_list');
375    
376            my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
377            my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
378    
379            my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
380    
381            $this_user_list->delete || croak "can't delete user from list\n";
382    
383            return $user_list->dbi_commit || croak "can't commit";
384    }
385    
386  =head2 add_message_to_list  =head2 add_message_to_list
387    
388  Adds message to one list's queue for later sending.  Adds message to one list's queue for later sending.
# Line 413  sub send_queued_messages { Line 522  sub send_queued_messages {
522                          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 )) {
523                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
524                          } else {                          } else {
525                                  print "=> $to_email\n";                                  print "=> $to_email ";
526    
527                                  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;
528                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
# Line 439  sub send_queued_messages { Line 548  sub send_queued_messages {
548                                  $m_obj->header_set('X-Nos-Hash', $hash);                                  $m_obj->header_set('X-Nos-Hash', $hash);
549    
550                                  # really send e-mail                                  # really send e-mail
551                                    my $sent_status;
552    
553                                  if (@email_send_options) {                                  if (@email_send_options) {
554                                          send $email_send_driver => $m_obj->as_string, @email_send_options;                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
555                                  } else {                                  } else {
556                                          send $email_send_driver => $m_obj->as_string;                                          $sent_status = send $email_send_driver => $m_obj->as_string;
557                                  }                                  }
558    
559                                  $sent->create({                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
560                                          message_id => $m->message_id,                                  my @bad = @{ $sent_status->prop('bad') };
561                                          user_id => $u->user_id,                                  croak "failed sending to ",join(",",@bad) if (@bad);
562                                          hash => $hash,  
563                                  });                                  if ($sent_status) {
564                                  $sent->dbi_commit;  
565                                            $sent->create({
566                                                    message_id => $m->message_id,
567                                                    user_id => $u->user_id,
568                                                    hash => $hash,
569                                            });
570                                            $sent->dbi_commit;
571    
572                                            print " - $sent_status\n";
573    
574                                    } else {
575                                            warn "ERROR: $sent_status\n";
576                                    }
577    
578                                  if ($sleep) {                                  if ($sleep) {
579                                          warn "sleeping $sleep seconds\n";                                          warn "sleeping $sleep seconds\n";
# Line 474  Receive single message for list's inbox. Line 597  Receive single message for list's inbox.
597          message => $message,          message => $message,
598   );   );
599    
600    This method is used by C<sender.pl> when receiving e-mail messages.
601    
602  =cut  =cut
603    
604  sub inbox_message {  sub inbox_message {
# Line 564  sub inbox_message { Line 689  sub inbox_message {
689    
690  Beware of dragons! You shouldn't need to call those methods directly.  Beware of dragons! You shouldn't need to call those methods directly.
691    
692    
693    =head2 _add_aliases
694    
695    Add new list to C</etc/aliases> (or equivavlent) file
696    
697     my $ok = $nos->add_aliases(
698            list => 'My list',
699            email => 'my-list@example.com',
700            aliases => '/etc/mail/mylist',
701            archive => '/path/to/mbox/archive',
702    
703     );
704    
705    C<archive> parametar is optional.
706    
707    Return false on failure.
708    
709    =cut
710    
711    sub _add_aliases {
712            my $self = shift;
713    
714            my $arg = {@_};
715    
716            croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});
717    
718            my $aliases = $arg->{'aliases'} || croak "need aliases";
719    
720            unless (-e $aliases) {
721                    warn "aliases file $aliases doesn't exist, creating empty\n";
722                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
723                    close($fh);
724            }
725    
726            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
727    
728            my $target = '';
729    
730            if (my $archive = $arg->{'archive'}) {
731                    $target .= "$archive, ";
732    
733                    if (! -e $archive) {
734                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
735    
736                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
737                            close($fh);
738                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
739                    }
740            }
741    
742            # resolve my path to absolute one
743            my $self_path = abs_path($0);
744            $self_path =~ s#/[^/]+$##;
745            $self_path =~ s#/t/*$#/#;
746    
747            $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;
748    
749            unless ($a->append($arg->{'email'}, $target)) {
750                    croak "can't add alias ".$a->error_check;
751            }
752    
753            return 1;
754    }
755    
756  =head2 _add_list  =head2 _add_list
757    
758  Create new list  Create new list
# Line 572  Create new list Line 761  Create new list
761          list => 'My list',          list => 'My list',
762          from => 'Outgoing from comment',          from => 'Outgoing from comment',
763          email => 'my-list@example.com',          email => 'my-list@example.com',
764            aliases => '/etc/mail/mylist',
765   );   );
766    
767  Returns C<Class::DBI> object for created list.  Returns C<Class::DBI> object for created list.
# Line 590  sub _add_list { Line 780  sub _add_list {
780    
781          my $name = lc($arg->{'list'}) || confess "can't add list without name";          my $name = lc($arg->{'list'}) || confess "can't add list without name";
782          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
783            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
784    
785          my $from_addr = $arg->{'from'};          my $from_addr = $arg->{'from'};
786    
787          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
788    
789            $self->_add_aliases(
790                    list => $name,
791                    email => $email,
792                    aliases => $aliases,
793            ) || croak "can't add alias $email for list $name";
794    
795          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
796                  name => $name,                  name => $name,
797                  email => $email,                  email => $email,
# Line 613  sub _add_list { Line 811  sub _add_list {
811  }  }
812    
813    
814    
815  =head2 _get_list  =head2 _get_list
816    
817  Get list C<Class::DBI> object.  Get list C<Class::DBI> object.
# Line 657  methods below). Line 856  methods below).
856    
857  my $nos;  my $nos;
858    
859    
860    =head2 new
861    
862    Create new SOAP object
863    
864     my $soap = new Nos::SOAP(
865            dsn => 'dbi:Pg:dbname=notices',
866            user => 'dpavlin',
867            passwd => '',
868            debug => 1,
869            verbose => 1,
870            hash_len => 8,
871            aliases => '/etc/aliases',
872     );
873    
874    =cut
875    
876  sub new {  sub new {
877          my $class = shift;          my $class = shift;
878          my $self = {@_};          my $self = {@_};
879    
880            croak "need aliases parametar" unless ($self->{'aliases'});
881    
882          bless($self, $class);          bless($self, $class);
883    
884          $nos = new Nos( @_ ) || die "can't create Nos object";          $nos = new Nos( @_ ) || die "can't create Nos object";
# Line 681  sub new { Line 900  sub new {
900  sub NewList {  sub NewList {
901          my $self = shift;          my $self = shift;
902    
903            my $aliases = $self->{'aliases'} || croak "Nos::SOAP need 'aliases' argument to new constructor";
904    
905          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
906                  return $nos->new_list(                  return $nos->new_list(
907                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
908                            aliases => $aliases,
909                  );                  );
910          } else {          } else {
911                  return $nos->new_list( %{ shift @_ } );                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );
912          }          }
913  }  }
914    
915    
916    =head2 DeleteList
917    
918     $ok = DeleteList(
919            list => 'My list',
920     );
921    
922    =cut
923    
924    sub DeleteList {
925            my $self = shift;
926    
927            if ($_[0] !~ m/^HASH/) {
928                    return $nos->delete_list(
929                            list => $_[0],
930                    );
931            } else {
932                    return $nos->delete_list( %{ shift @_ } );
933            }
934    }
935    
936  =head2 AddMemberToList  =head2 AddMemberToList
937    
938   $member_id = AddMemberToList(   $member_id = AddMemberToList(
939          list => 'My list',          list => 'My list',
940          email => 'e-mail@example.com',          email => 'e-mail@example.com',
941          name => 'Full Name'          name => 'Full Name',
942            ext_id => 42,
943   );   );
944    
945  =cut  =cut
# Line 706  sub AddMemberToList { Line 949  sub AddMemberToList {
949    
950          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
951                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
952                          list => $_[0], email => $_[1], name => $_[2],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
953                  );                  );
954          } else {          } else {
955                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 722  sub AddMemberToList { Line 965  sub AddMemberToList {
965    
966  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
967    
968    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
969    seems that SOAP::Lite client thinks that it has array with one element which
970    is array of hashes with data.
971    
972  =cut  =cut
973    
974  sub ListMembers {  sub ListMembers {
# Line 735  sub ListMembers { Line 982  sub ListMembers {
982                  $list_name = $_[0]->{'list'};                  $list_name = $_[0]->{'list'};
983          }          }
984    
985          return $nos->list_members( list => $list_name );          return [ $nos->list_members( list => $list_name ) ];
986  }  }
987    
988    
989    =head2 DeleteMemberFromList
990    
991     $member_id = DeleteMemberFromList(
992            list => 'My list',
993            email => 'e-mail@example.com',
994     );
995    
996    =cut
997    
998    sub DeleteMemberFromList {
999            my $self = shift;
1000    
1001            if ($_[0] !~ m/^HASH/) {
1002                    return $nos->delete_member_from_list(
1003                            list => $_[0], email => $_[1],
1004                    );
1005            } else {
1006                    return $nos->delete_member_from_list( %{ shift @_ } );
1007            }
1008    }
1009    
1010    
1011  =head2 AddMessageToList  =head2 AddMessageToList
1012    
1013   $message_id = AddMessageToList(   $message_id = AddMessageToList(
Legend:
Removed from v.56  
changed lines
  Added in v.66
  ViewVC Help
Powered by ViewVC 1.1.26