/[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!

Diff of /trunk/Nos.pm

Parent Directory | Revision Log | View Patch Patch

-revision 60 by dpavlin,
Tue Jun 21 21:24:10 2005 UTC
+revision 93 by dpavlin,
Tue Dec 19 15:04:05 2006 UTC
 Line 16 
 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
  our @EXPORT = qw(
  );
- our $VERSION = '0.5';
+ our $VERSION = '0.9';
  use Class::DBI::Loader;
  use Email::Valid;
 Line 27 
 use Email::Simple;
  use Email::Address;
  use Mail::DeliveryStatus::BounceParser;
  use Class::DBI::AbstractSearch;
+ use SQL::Abstract;
+ use Mail::Alias;
+ use Cwd qw(abs_path);
  =head1 NAME
-Line 60 
 encoded) or anything else.
+Line 63 
 encoded) or anything else.
  It will just queue your e-mail message to particular list (sending it to
  possibly remote Notice Sender SOAP server just once), send it out at
  reasonable rate (so that it doesn't flood your e-mail infrastructure) and
- track replies.
+ keep track replies.
- It is best used to send smaller number of messages to more-or-less fixed
+ It is best used to send small number of messages to more-or-less fixed
  list of recipients while allowing individual responses to be examined.
  Tipical use include replacing php e-mail sending code with SOAP call to
  Notice Sender. It does support additional C<ext_id> field for each member
-Line 70 
 which can be used to track some unique i
+Line 73 
 which can be used to track some unique i
  particular user.
  It comes with command-line utility C<sender.pl> which can be used to perform
- all available operation from scripts (see C<perldoc sender.pl>).
+ all available operation from scripts (see C<sender.pl --man>).
  This command is also useful for debugging while writing client SOAP
  application.
-Line 87 
 Create new instance specifing database,
+Line 90 
 Create new instance specifing database,
          debug => 1,
          verbose => 1,
          hash_len => 8,
+         full_hostname_in_aliases => 0,
   );
  Parametar C<hash_len> defines length of hash which will be added to each
  outgoing e-mail message to ensure that replies can be linked with sent e-mails.
+ C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
+ postalias) to include full hostname in aliases file.
  =cut
  sub new {
          my $class = shift;
          my $self = {@_};
          bless($self, $class);
          croak "need at least dsn" unless ($self->{'dsn'});
-Line 118 
 sub new {
+Line 126 
 sub new {
  }
- =head2 new_list
+ =head2 create_list
- Create new list. Required arguments are name of C<list> and
+ Create new list. Required arguments are name of C<list>, C<email> address
- C<email> address.
+ and path to C<aliases> file.
-  $nos->new_list(
+  $nos->create_list(
          list => 'My list',
          from => 'Outgoing from comment',
          email => 'my-list@example.com',
+         aliases => '/etc/mail/mylist',
+         archive => '/path/to/mbox/archive',
   );
  Returns ID of newly created list.
-Line 135 
 Calls internally C<_add_list>, see detai
+Line 145 
 Calls internally C<_add_list>, see detai
  =cut
- sub new_list {
+ sub create_list {
          my $self = shift;
          my $arg = {@_};
-Line 154 
 sub new_list {
+Line 164 
 sub new_list {
  }
+ =head2 drop_list
+ Delete list from database.
+  my $ok = drop_list(
+         list => 'My list'
+         aliases => '/etc/mail/mylist',
+  );
+ Returns false if list doesn't exist.
+ =cut
+ sub drop_list {
+         my $self = shift;
+         my $args = {@_};
+         croak "need list to delete" unless ($args->{'list'});
+         $args->{'list'} = lc($args->{'list'});
+         my $aliases = $args->{'aliases'} || croak "need path to aliases file";
+         my $lists = $self->{'loader'}->find_class('lists');
+         my $this_list = $lists->search( name => $args->{'list'} )->first || return;
+         $self->_remove_alias( email => $this_list->email, aliases => $aliases);
+         $this_list->delete || croak "can't delete list\n";
+         return $lists->dbi_commit || croak "can't commit";
+ }
  =head2 add_member_to_list
  Add new member to list
-Line 227 
 List all members of some list.
+Line 273 
 List all members of some list.
          list => 'My list',
   );
- Returns array of hashes with user informations like this:
+ Returns array of hashes with user information like this:
   $member = {
          name => 'Dobrica Pavlinusic',
-Line 343 
 sub delete_member_from_list {
+Line 389 
 sub delete_member_from_list {
          my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
          my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
-         my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;
+         my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
          $this_user_list->delete || croak "can't delete user from list\n";
-Line 380 
 sub add_message_to_list {
+Line 426 
 sub add_message_to_list {
          my $m = Email::Simple->new($message_text) || croak "can't parse message";
-         unless( $m->header('Subject') ) {
+         warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
-                 warn "message doesn't have Subject header\n";
-                 return;
-         }
          my $lists = $self->{'loader'}->find_class('lists');
-Line 420 
 Send queued messages or just ones for se
+Line 463 
 Send queued messages or just ones for se
          list => 'My list',
          driver => 'smtp',
          sleep => 3,
+         verbose => 1,
   );
  Second option is driver which will be used for e-mail delivery. If not
-Line 433 
 Other valid drivers are:
+Line 477 
 Other valid drivers are:
  Send e-mail using SMTP server at 127.0.0.1
+ =item verbose
+ Display diagnostic output to C<STDOUT> and C<STDERR>.
  =back
+ Any other driver name will try to use C<Email::Send::that_driver> module.
  Default sleep wait between two messages is 3 seconds.
+ This method will return number of succesfully sent messages.
  =cut
  sub send_queued_messages {
-Line 447 
 sub send_queued_messages {
+Line 499 
 sub send_queued_messages {
          my $list_name = lc($arg->{'list'}) || '';
          my $driver = $arg->{'driver'} || '';
          my $sleep = $arg->{'sleep'};
+         my $verbose = $arg->{verbose};
          $sleep ||= 3 unless defined($sleep);
+         # number of messages sent o.k.
+         my $ok = 0;
          my $email_send_driver = 'Email::Send::IO';
          my @email_send_options;
          if (lc($driver) eq 'smtp') {
                  $email_send_driver = 'Email::Send::SMTP';
                  @email_send_options = ['127.0.0.1'];
+         } elsif ($driver && $driver ne '') {
+                 $email_send_driver = 'Email::Send::' . $driver;
          } else {
-                 warn "dumping all messages to STDERR\n";
+                 warn "dumping all messages to STDERR\n" if ($verbose);
          }
          my $lists = $self->{'loader'}->find_class('lists');
-Line 477 
 sub send_queued_messages {
+Line 535 
 sub send_queued_messages {
          while (my $m = $my_q->next) {
                  next if ($m->all_sent);
-                 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
+                 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
                  my $msg = $m->message_id->message;
                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
-Line 487 
 sub send_queued_messages {
+Line 545 
 sub send_queued_messages {
                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);
                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
-                                 print "SKIP $to_email message allready sent\n";
+                                 print "SKIP $to_email message allready sent\n" if ($verbose);
                          } else {
-                                 print "=> $to_email\n";
+                                 print "=> $to_email " if ($verbose);
                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
-Line 506 
 sub send_queued_messages {
+Line 564 
 sub send_queued_messages {
                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
-                                 $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
+                                 #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
-Line 515 
 sub send_queued_messages {
+Line 573 
 sub send_queued_messages {
                                  $m_obj->header_set('X-Nos-Hash', $hash);
                                  # really send e-mail
+                                 my $sent_status;
                                  if (@email_send_options) {
-                                         send $email_send_driver => $m_obj->as_string, @email_send_options;
+                                         $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
                                  } else {
-                                         send $email_send_driver => $m_obj->as_string;
+                                         $sent_status = send $email_send_driver => $m_obj->as_string;
                                  }
-                                 $sent->create({
+                                 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
-                                         message_id => $m->message_id,
+                                 my @bad;
-                                         user_id => $u->user_id,
+                                 @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
-                                         hash => $hash,
+                                 croak "failed sending to ",join(",",@bad) if (@bad);
-                                 });
-                                 $sent->dbi_commit;
+                                 if ($sent_status) {
+                                         $sent->create({
+                                                 message_id => $m->message_id,
+                                                 user_id => $u->user_id,
+                                                 hash => $hash,
+                                         });
+                                         $sent->dbi_commit;
+                                         print " - $sent_status\n" if ($verbose);
+                                         $ok++;
+                                 } else {
+                                         warn "ERROR: $sent_status\n" if ($verbose);
+                                 }
                                  if ($sleep) {
-                                         warn "sleeping $sleep seconds\n";
+                                         warn "sleeping $sleep seconds\n" if ($verbose);
                                          sleep($sleep);
                                  }
                          }
-Line 539 
 sub send_queued_messages {
+Line 613 
 sub send_queued_messages {
                  $m->dbi_commit;
          }
+         return $ok;
  }
  =head2 inbox_message
-Line 637 
 sub inbox_message {
+Line 713 
 sub inbox_message {
  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
  }
+ =head2 received_messages
+ Returns all received messages for given list or user.
+  my @received = $nos->received_messages(
+         list => 'My list',
+         email => "john.doe@example.com",
+         from_date => '2005-01-01 10:15:00',
+         to_date => '2005-01-01 12:00:00',
+         message => 0,
+  );
+ If don't specify C<list> or C<email> it will return all received messages.
+ Results will be sorted by received date, oldest first.
+ Other optional parametars include:
+ =over 10
+ =item from_date
+ Date (in ISO format) for lower limit of dates received
+ =item to_date
+ Return just messages older than this date
+ =item message
+ Include whole received message in result. This will probably make result
+ array very large. Use with care.
+ =back
+ Date ranges are inclusive, so results will include messages sent on
+ particular date specified with C<date_from> or C<date_to>.
+ Each element in returned array will have following structure:
+  my $row = {
+         id => 42,                       # unique ID of received message
+         list => 'My list',              # useful if filtering by email
+         ext_id => 9999,                 # ext_id from message sender
+         email => 'jdoe@example.com',    # e-mail of message sender
+         bounced => 0,                   # true if message is bounce
+         date => '2005-08-24 18:57:24',  # date of receival in ISO format
+  }
+ If you specified C<message> option, this hash will also have C<message> key
+ which will contain whole received message.
+ =cut
+ sub received_messages {
+         my $self = shift;
+         my $arg = {@_} if (@_);
+ #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
+         my $sql = qq{
+                         select
+                                 received.id as id,
+                                 lists.name as list,
+                                 users.ext_id as ext_id,
+                                 users.email as email,
+         };
+         $sql .= qq{             message,} if ($arg->{'message'});
+         $sql .= qq{
+                                 bounced,received.date as date
+                         from received
+                         join lists on lists.id = list_id
+                         join users on users.id = user_id
+         };
+         my $order = qq{ order by date asc };
+         my $where;
+         $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
+         $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
+         $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
+         $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
+         # hum, yammy one-liner
+         my($stmt, @bind)  = SQL::Abstract->new->where($where);
+         my $dbh = $self->{'loader'}->find_class('received')->db_Main;
+         my $sth = $dbh->prepare($sql . $stmt . $order);
+         $sth->execute(@bind);
+         return $sth->fetchall_hash;
+ }
  =head1 INTERNAL METHODS
  Beware of dragons! You shouldn't need to call those methods directly.
+ =head2 _add_aliases
+ Add or update alias in C</etc/aliases> (or equivalent) file for selected list
+  my $ok = $nos->add_aliases(
+         list => 'My list',
+         email => 'my-list@example.com',
+         aliases => '/etc/mail/mylist',
+         archive => '/path/to/mbox/archive',
+  );
+ C<archive> parametar is optional.
+ Return false on failure.
+ =cut
+ sub _add_aliases {
+         my $self = shift;
+         my $arg = {@_};
+         foreach my $o (qw/list email aliases/) {
+                 croak "need $o option" unless ($arg->{$o});
+         }
+         my $aliases = $arg->{'aliases'};
+         my $email = $arg->{'email'};
+         my $list = $arg->{'list'};
+         unless (-e $aliases) {
+                 warn "aliases file $aliases doesn't exist, creating empty\n";
+                 open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
+                 close($fh);
+                 chmod 0777, $aliases || warn "can't change permission to 0777";
+         }
+         die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
+         my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
+         my $target = '';
+         if (my $archive = $arg->{'archive'}) {
+                 $target .= "$archive, ";
+                 if (! -e $archive) {
+                         warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
+                         open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
+                         close($fh);
+                         chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
+                 }
+         }
+         # resolve my path to absolute one
+         my $self_path = abs_path($0);
+         $self_path =~ s#/[^/]+$##;
+         $self_path =~ s#/t/*$#/#;
+         $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
+         # remove hostname from email to make Postfix's postalias happy
+         $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
+         if ($a->exists($email)) {
+                 $a->update($email, $target) or croak "can't update alias ".$a->error_check;
+         } else {
+                 $a->append($email, $target) or croak "can't add alias ".$a->error_check;
+         }
+ #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
+         return 1;
+ }
  =head2 _add_list
  Create new list
-Line 650 
 Create new list
+Line 898 
 Create new list
          list => 'My list',
          from => 'Outgoing from comment',
          email => 'my-list@example.com',
+         aliases => '/etc/mail/mylist',
   );
  Returns C<Class::DBI> object for created list.
-Line 668 
 sub _add_list {
+Line 917 
 sub _add_list {
          my $name = lc($arg->{'list'}) || confess "can't add list without name";
          my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
+         my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
          my $from_addr = $arg->{'from'};
          my $lists = $self->{'loader'}->find_class('lists');
+         $self->_add_aliases(
+                 list => $name,
+                 email => $email,
+                 aliases => $aliases,
+         ) || warn "can't add alias $email for list $name";
          my $l = $lists->find_or_create({
                  name => $name,
                  email => $email,
-Line 691 
 sub _add_list {
+Line 948 
 sub _add_list {
  }
  =head2 _get_list
  Get list C<Class::DBI> object.
-Line 711 
 sub _get_list {
+Line 969 
 sub _get_list {
          return $lists->search({ name => lc($name) })->first;
  }
+ =head2 _remove_alias
+ Remove list alias
+  my $ok = $nos->_remove_alias(
+         email => 'mylist@example.com',
+         aliases => '/etc/mail/mylist',
+  );
+ Returns true if list is removed or false if list doesn't exist. Dies in case of error.
+ =cut
+ sub _remove_alias {
+         my $self = shift;
+         my $arg = {@_};
+         my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
+         my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
+         my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
+         if ($a->exists($email)) {
+                 $a->delete($email) || croak "can't remove alias $email";
+         } else {
+                 return 0;
+         }
+         return 1;
+ }
  ###
  ### SOAP
  ###
-Line 735 
 methods below).
+Line 1027 
 methods below).
  my $nos;
+ =head2 new
+ Create new SOAP object
+  my $soap = new Nos::SOAP(
+         dsn => 'dbi:Pg:dbname=notices',
+         user => 'dpavlin',
+         passwd => '',
+         debug => 1,
+         verbose => 1,
+         hash_len => 8,
+         aliases => '/etc/aliases',
+  );
+ If you are writing SOAP server (like C<soap.cgi> example), you will need to
+ call this method once to make new instance of Nos::SOAP and specify C<dsn>
+ and options for it.
+ =cut
  sub new {
          my $class = shift;
          my $self = {@_};
+         croak "need aliases parametar" unless ($self->{'aliases'});
          bless($self, $class);
          $nos = new Nos( @_ ) || die "can't create Nos object";
-Line 746 
 sub new {
+Line 1062 
 sub new {
  }
- =head2 NewList
+ =head2 CreateList
-  $message_id = NewList(
+  $message_id = CreateList(
          list => 'My list',
          from => 'Name of my list',
          email => 'my-list@example.com'
-Line 756 
 sub new {
+Line 1072 
 sub new {
  =cut
- sub NewList {
+ sub CreateList {
          my $self = shift;
+         my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
          if ($_[0] !~ m/^HASH/) {
-                 return $nos->new_list(
+                 return $nos->create_list(
                          list => $_[0], from => $_[1], email => $_[2],
+                         aliases => $aliases,
                  );
          } else {
-                 return $nos->new_list( %{ shift @_ } );
+                 return $nos->create_list( %{ shift @_ }, aliases => $aliases );
          }
  }
+ =head2 DropList
+  $ok = DropList(
+         list => 'My list',
+  );
+ =cut
+ sub DropList {
+         my $self = shift;
+         my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
+         if ($_[0] !~ m/^HASH/) {
+                 return $nos->drop_list(
+                         list => $_[0],
+                         aliases => $aliases,
+                 );
+         } else {
+                 return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
+         }
+ }
  =head2 AddMemberToList
   $member_id = AddMemberToList(
-Line 785 
 sub AddMemberToList {
+Line 1127 
 sub AddMemberToList {
          if ($_[0] !~ m/^HASH/) {
                  return $nos->add_member_to_list(
-                         list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
+                         list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
                  );
          } else {
                  return $nos->add_member_to_list( %{ shift @_ } );
-Line 814 
 sub ListMembers {
+Line 1156 
 sub ListMembers {
                  $list_name = $_[0]->{'list'};
          }
-         return $nos->list_members( list => $list_name );
+         return [ $nos->list_members( list => $list_name ) ];
+ }
+ =head2 DeleteMemberFromList
+  $member_id = DeleteMemberFromList(
+         list => 'My list',
+         email => 'e-mail@example.com',
+  );
+ =cut
+ sub DeleteMemberFromList {
+         my $self = shift;
+         if ($_[0] !~ m/^HASH/) {
+                 return $nos->delete_member_from_list(
+                         list => $_[0], email => $_[1],
+                 );
+         } else {
+                 return $nos->delete_member_from_list( %{ shift @_ } );
+         }
  }
  =head2 AddMessageToList
   $message_id = AddMessageToList(
-Line 838 
 sub AddMessageToList {
+Line 1203 
 sub AddMessageToList {
          }
  }
+ =head2 MessagesReceived
+ Return statistics about received messages.
+  my @result = MessagesReceived(
+         list => 'My list',
+         email => 'jdoe@example.com',
+         from_date => '2005-01-01 10:15:00',
+         to_date => '2005-01-01 12:00:00',
+         message => 0,
+  );
+ You must specify C<list> or C<email> or any combination of those two. Other
+ parametars are optional.
+ For format of returned array element see C<received_messages>.
+ =cut
+ sub MessagesReceived {
+         my $self = shift;
+         if ($_[0] !~ m/^HASH/) {
+                 die "need at least list or email" unless (scalar @_ < 2);
+                 return \@{ $nos->received_messages(
+                         list => $_[0], email => $_[1],
+                         from_date => $_[2], to_date => $_[3],
+                         message => $_[4]
+                 ) };
+         } else {
+                 my $arg = shift;
+                 die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
+                 return \@{ $nos->received_messages( %{ $arg } ) };
+         }
+ }
+ =head2 SendTest
+ Internal function which does e-mail sending using C<Email::Send::Test> driver.
+   my $sent = SendTest( list => 'My list' );
+ Returns number of messages sent
+ =cut
+ sub SendTest {
+         my $self = shift;
+         my $args = shift;
+         die "list name required" unless ($args->{list});
+         require Email::Send::Test;
+         my $nr_sent = $nos->send_queued_messages(
+                 list => $args->{list},
+                 driver => 'Test',
+                 sleep => 0,
+                 verbose => 0,
+         );
+         my @emails = Email::Send::Test->emails;
+         open(my $tmp, ">/tmp/soap-debug");
+         use Data::Dump qw/dump/;
+         print $tmp "sent $nr_sent emails\n", dump(@emails);
+         close($tmp);
+         return $nr_sent;
+ }
  ###
+ =head1 NOTE ON ARRAYS IN SOAP
+ Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
+ seems that SOAP::Lite client thinks that it has array with one element which
+ is array of hashes with data.
  =head1 EXPORT
  Nothing.

 Legend:



Removed from v.60
 


changed lines


 
Added in v.93
 Legend:



Removed from v.60
 


changed lines


 
Added in v.93
-Removed from v.60
+Added in v.93

	ViewVC Help
Powered by ViewVC 1.1.26